.emacs.d.git - Gitblit

Chizi123

2018-11-18 8f6f2705a38e2515b6c57fda12c5be29fb9a798f

commit \| author \| age
5cb5f7	1	;;; ghub.el --- minuscule client libraries for Git forge APIs -- lexical-binding: t --
C	2
	3	;; Copyright (C) 2016-2018 Jonas Bernoulli
	4
	5	;; Author: Jonas Bernoulli <jonas@bernoul.li>
	6	;; Homepage: https://github.com/magit/ghub
	7	;; Keywords: tools
	8
	9	;; This file is not part of GNU Emacs.
	10
	11	;; This file is free software; you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation; either version 3, or (at your option)
	14	;; any later version.
	15
	16	;; This file is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
	20
	21	;; For a copy of the GPL see https://www.gnu.org/licenses/gpl.txt.
	22
	23	;;; Commentary:
	24
	25	;; Ghub provides basic support for using the APIs of various Git forges
	26	;; from Emacs packages. Originally it only supported the Github REST
	27	;; API, but now it also supports the Github GraphQL API as well as the
	28	;; REST APIs of Gitlab, Gitea, Gogs and Bitbucket.
	29
	30	;; Ghub abstracts access to API resources using only a handful of basic
	31	;; functions such as `ghub-get'. These are convenience wrappers around
	32	;; `ghub-request'. Additional forge-specific wrappers like `glab-put',
	33	;; `gtea-put', `gogs-post' and `buck-delete' are also available. Ghub
	34	;; does not provide any resource-specific functions, with the exception
	35	;; of `FORGE-repository-id'.
	36
	37	;; When accessing Github, then Ghub handles the creation and storage of
	38	;; access tokens using a setup wizard to make it easier for users to get
	39	;; started. The tokens for other forges have to be created manually.
	40
	41	;; Ghub is intentionally limited to only provide these two essential
	42	;; features — basic request functions and guided setup — to avoid being
	43	;; too opinionated, which would hinder wide adoption. It is assumed that
	44	;; wide adoption would make life easier for users and maintainers alike,
	45	;; because then all packages that talk to forge APIs could be configured
	46	;; the same way.
	47
	48	;; Please consult the manual (info "ghub") for more information.
	49
	50	;;; Code:
	51
	52	(require 'auth-source)
	53	(require 'cl-lib)
	54	(require 'json)
	55	(require 'let-alist)
	56	(require 'url)
	57	(require 'url-auth)
	58	(require 'url-http)
	59
	60	(eval-when-compile
	61	(require 'subr-x))
	62
	63	(defvar url-callback-arguments)
	64	(defvar url-http-end-of-headers)
	65	(defvar url-http-extra-headers)
	66	(defvar url-http-response-status)
	67
	68	;;; Settings
	69
	70	(defconst ghub-default-host "api.github.com"
	71	"The default host that is used if `ghub.host' is not set.")
	72
	73	(defvar ghub-github-token-scopes '(repo)
	74	"The Github API scopes that your private tools need.
	75
	76	The token that is created based on the value of this variable
	77	is used when `ghub-request' (or one of its wrappers) is called
	78	without providing a value for AUTH. Packages should always
	79	identify themselves using that argument, but when you use Ghub
	80	directly in private tools, then that is not necessary and the
	81	request is made on behalf of the `ghub' package itself, aka on
	82	behalf of some private tool.
	83
	84	By default the only requested scope is `repo' because that is
	85	sufficient as well as required for most common uses. This and
	86	other scopes are documented at URL `https://magit.vc/goto/2e586d36'.
	87
	88	If your private tools need other scopes, then you have to add
	89	them here before creating the token. Alternatively you can
	90	edit the scopes of an existing token using the web interface
	91	at URL `https://github.com/settings/tokens'.")
	92
	93	(defvar ghub-override-system-name nil
	94	"If non-nil, the string used to identify the local machine.
	95	If this is nil, then the value returned by `system-name' is
	96	used instead.")
	97
	98	;;; Request
	99	;;;; Object
	100
	101	(cl-defstruct (ghub--req
	102	(:constructor ghub--make-req)
	103	(:copier nil))
	104	(url nil :read-only nil)
	105	(forge nil :read-only t)
	106	(silent nil :read-only t)
	107	(method nil :read-only t)
	108	(headers nil :read-only t)
	109	(handler nil :read-only t)
	110	(unpaginate nil :read-only nil)
	111	(noerror nil :read-only t)
	112	(reader nil :read-only t)
	113	(callback nil :read-only t)
	114	(errorback nil :read-only t)
	115	(value nil :read-only nil)
	116	(extra nil :read-only nil))
	117
	118	(defalias 'ghub-req-extra 'ghub--req-extra)
	119
	120	;;;; API
	121
	122	(define-error 'ghub-error "Ghub/Url Error" 'error)
	123	(define-error 'ghub-http-error "HTTP Error" 'ghub-error)
	124
	125	(defvar ghub-response-headers nil
	126	"The headers returned in response to the last request.
	127	`ghub-request' returns the response body and stores the
	128	response headers in this variable.")
	129
	130	(cl-defun ghub-head (resource &optional params
	131	&key query payload headers
	132	silent unpaginate noerror reader
	133	username auth host
	134	callback errorback extra)
	135	"Make a `HEAD' request for RESOURCE, with optional query PARAMS.
	136	Like calling `ghub-request' (which see) with \"HEAD\" as METHOD."
	137	(ghub-request "HEAD" resource params
	138	:query query :payload payload :headers headers
	139	:silent silent :unpaginate unpaginate
	140	:noerror noerror :reader reader
	141	:username username :auth auth :host host
	142	:callback callback :errorback errorback :extra extra))
	143
	144	(cl-defun ghub-get (resource &optional params
	145	&key query payload headers
	146	silent unpaginate noerror reader
	147	username auth host
	148	callback errorback extra)
	149	"Make a `GET' request for RESOURCE, with optional query PARAMS.
	150	Like calling `ghub-request' (which see) with \"GET\" as METHOD."
	151	(ghub-request "GET" resource params
	152	:query query :payload payload :headers headers
	153	:silent silent :unpaginate unpaginate
	154	:noerror noerror :reader reader
	155	:username username :auth auth :host host
	156	:callback callback :errorback errorback :extra extra))
	157
	158	(cl-defun ghub-put (resource &optional params
	159	&key query payload headers
	160	silent unpaginate noerror reader
	161	username auth host
	162	callback errorback extra)
	163	"Make a `PUT' request for RESOURCE, with optional payload PARAMS.
	164	Like calling `ghub-request' (which see) with \"PUT\" as METHOD."
	165	(ghub-request "PUT" resource params
	166	:query query :payload payload :headers headers
	167	:silent silent :unpaginate unpaginate
	168	:noerror noerror :reader reader
	169	:username username :auth auth :host host
	170	:callback callback :errorback errorback :extra extra))
	171
	172	(cl-defun ghub-post (resource &optional params
	173	&key query payload headers
	174	silent unpaginate noerror reader
	175	username auth host
	176	callback errorback extra)
	177	"Make a `POST' request for RESOURCE, with optional payload PARAMS.
	178	Like calling `ghub-request' (which see) with \"POST\" as METHOD."
	179	(ghub-request "POST" resource params
	180	:query query :payload payload :headers headers
	181	:silent silent :unpaginate unpaginate
	182	:noerror noerror :reader reader
	183	:username username :auth auth :host host
	184	:callback callback :errorback errorback :extra extra))
	185
	186	(cl-defun ghub-patch (resource &optional params
	187	&key query payload headers
	188	silent unpaginate noerror reader
	189	username auth host
	190	callback errorback extra)
	191	"Make a `PATCH' request for RESOURCE, with optional payload PARAMS.
	192	Like calling `ghub-request' (which see) with \"PATCH\" as METHOD."
	193	(ghub-request "PATCH" resource params
	194	:query query :payload payload :headers headers
	195	:silent silent :unpaginate unpaginate
	196	:noerror noerror :reader reader
	197	:username username :auth auth :host host
	198	:callback callback :errorback errorback :extra extra))
	199
	200	(cl-defun ghub-delete (resource &optional params
	201	&key query payload headers
	202	silent unpaginate noerror reader
	203	username auth host
	204	callback errorback extra)
	205	"Make a `DELETE' request for RESOURCE, with optional payload PARAMS.
	206	Like calling `ghub-request' (which see) with \"DELETE\" as METHOD."
	207	(ghub-request "DELETE" resource params
	208	:query query :payload payload :headers headers
	209	:silent silent :unpaginate unpaginate
	210	:noerror noerror :reader reader
	211	:username username :auth auth :host host
	212	:callback callback :errorback errorback :extra extra))
	213
	214	(cl-defun ghub-request (method resource &optional params
	215	&key query payload headers
	216	silent unpaginate noerror reader
	217	username auth host forge
	218	callback errorback value extra)
	219	"Make a request for RESOURCE and return the response body.
	220
	221	Also place the response header in `ghub-response-headers'.
	222
	223	METHOD is the HTTP method, given as a string.
	224	RESOURCE is the resource to access, given as a string beginning
	225	with a slash.
	226
	227	PARAMS, QUERY, PAYLOAD and HEADERS are alists used to specify
	228	data. The Github API documentation is vague on how data has
	229	to be transmitted and for a particular resource usually just
	230	talks about \"parameters\". Generally speaking when the METHOD
	231	is \"HEAD\" or \"GET\", then they have to be transmitted as a
	232	query, otherwise as a payload.
	233	Use PARAMS to automatically transmit like QUERY or PAYLOAD would
	234	depending on METHOD.
	235	Use QUERY to explicitly transmit data as a query.
	236	Use PAYLOAD to explicitly transmit data as a payload.
	237	Instead of an alist, PAYLOAD may also be a string, in which
	238	case it gets encoded as UTF-8 but is otherwise transmitted as-is.
	239	Use HEADERS for those rare resources that require that the data
	240	is transmitted as headers instead of as a query or payload.
	241	When that is the case, then the API documentation usually
	242	mentions it explicitly.
	243
	244	If SILENT is non-nil, then don't message progress reports and
	245	the like.
	246
	247	If UNPAGINATE is t, then make as many requests as necessary to
	248	get all values. If UNPAGINATE is a natural number, then get
	249	at most that many pages. For any other non-nil value raise
	250	an error.
	251	If NOERROR is non-nil, then do not raise an error if the request
	252	fails and return nil instead. If NOERROR is `return', then
	253	return the error payload instead of nil.
	254	If READER is non-nil, then it is used to read and return from the
	255	response buffer. The default is `ghub--read-json-payload'.
	256	For the very few resources that do not return JSON, you might
	257	want to use `ghub--decode-payload'.
	258
	259	If USERNAME is non-nil, then make a request on behalf of that
	260	user. It is better to specify the user using the Git variable
	261	`github.user' for \"api.github.com\", or `github.HOST.user' if
	262	connecting to a Github Enterprise instance.
	263
	264	Each package that uses `ghub' should use its own token. If AUTH
	265	is nil, then the generic `ghub' token is used instead. This
	266	is only acceptable for personal utilities. A packages that
	267	is distributed to other users should always use this argument
	268	to identify itself, using a symbol matching its name.
	269
	270	Package authors who find this inconvenient should write a
	271	wrapper around this function and possibly for the
	272	method-specific functions as well.
	273
	274	Some symbols have a special meaning. `none' means to make an
	275	unauthorized request. `basic' means to make a password based
	276	request. If the value is a string, then it is assumed to be
	277	a valid token. `basic' and an explicit token string are only
	278	intended for internal and debugging uses.
	279
	280	If AUTH is a package symbol, then the scopes are specified
	281	using the variable `AUTH-github-token-scopes'. It is an error
	282	if that is not specified. See `ghub-github-token-scopes' for
	283	an example.
	284
	285	If HOST is non-nil, then connect to that Github instance. This
	286	defaults to \"api.github.com\". When a repository is connected
	287	to a Github Enterprise instance, then it is better to specify
	288	that using the Git variable `github.host' instead of using this
	289	argument.
	290
	291	If FORGE is `gitlab', then connect to Gitlab.com or, depending
	292	on HOST, to another Gitlab instance. This is only intended for
	293	internal use. Instead of using this argument you should use
	294	function `glab-request' and other `glab-*' functions.
	295
	296	If CALLBACK and/or ERRORBACK is non-nil, then make one or more
	297	asynchronous requests and call CALLBACK or ERRORBACK when
	298	finished. If an error occurred, then call ERRORBACK, or if
	299	that is nil, then CALLBACK. When no error occurred then call
	300	CALLBACK. When making asynchronous requests, then no errors
	301	are signaled, regardless of the value of NOERROR.
	302
	303	Both callbacks are called with four arguments.
	304	1. For CALLBACK, the combined value of the retrieved pages.
	305	For ERRORBACK, the error that occured when retrieving the
	306	last page.
	307	2. The headers of the last page as an alist.
	308	3. Status information provided by `url-retrieve'. Its `:error'
	309	property holds the same information as ERRORBACK's first
	310	argument.
	311	4. A `ghub--req' struct, which can be passed to `ghub-continue'
	312	(which see) to retrieve the next page, if any."
	313	(cl-assert (or (booleanp unpaginate) (natnump unpaginate)))
	314	(unless (string-prefix-p "/" resource)
	315	(setq resource (concat "/" resource)))
	316	(unless host
	317	(setq host (ghub--host forge)))
	318	(unless (or username (stringp auth) (eq auth 'none))
	319	(setq username (ghub--username host forge)))
	320	(cond ((not params))
	321	((member method '("GET" "HEAD"))
	322	(when query
	323	(error "PARAMS and QUERY are mutually exclusive for METHOD %S"
	324	method))
	325	(setq query params))
	326	(t
	327	(when payload
	328	(error "PARAMS and PAYLOAD are mutually exclusive for METHOD %S"
	329	method))
	330	(setq payload params)))
	331	(when (or callback errorback)
	332	(setq noerror t))
	333	(ghub--retrieve
	334	(ghub--encode-payload payload)
	335	(ghub--make-req
	336	:url (url-generic-parse-url
	337	(concat "https://" host resource
	338	(and query (concat "?" (ghub--url-encode-params query)))))
	339	:forge forge
	340	:silent silent
	341	;; Encode in case caller used (symbol-name 'GET). #35
	342	:method (encode-coding-string method 'utf-8)
	343	:headers (ghub--headers headers host auth username forge)
	344	:handler 'ghub--handle-response
	345	:unpaginate unpaginate
	346	:noerror noerror
	347	:reader reader
	348	:callback callback
	349	:errorback errorback
	350	:value value
	351	:extra extra)))
	352
	353	(defun ghub-continue (req)
	354	"If there is a next page, then retrieve that.
	355
	356	This function is only intended to be called from callbacks. If
	357	there is a next page, then retrieve that and return the buffer
	358	that the result will be loaded into, or t if the process has
	359	already completed. If there is no next page, then return nil.
	360
	361	Callbacks are called with four arguments (see `ghub-request').
	362	The forth argument is a `ghub--req' struct, intended to be passed
	363	to this function. A callback may use the struct's `extra' slot
	364	to pass additional information to the callback that will be
	365	called after the next request has finished. Use the function
	366	`ghub-req-extra' to get and set the value of this slot."
	367	(and (assq 'next (ghub-response-link-relations req))
	368	(or (ghub--retrieve nil req) t)))
	369
	370	(cl-defun ghub-wait (resource &optional duration &key username auth host)
	371	"Busy-wait up to DURATION seconds for RESOURCE to become available.
	372
	373	DURATION specifies how many seconds to wait at most. It defaults
	374	to 64 seconds. The first attempt is made immediately, the second
	375	after two seconds, and each subsequent attempt is made after
	376	waiting as long again as we already waited between all preceding
	377	attempts combined.
	378
	379	See `ghub-request' for information about the other arguments."
	380	(unless duration
	381	(setq duration 64))
	382	(with-local-quit
	383	(let ((total 0))
	384	(while (not (ghub-get resource nil
	385	:noerror t
	386	:username username
	387	:auth auth
	388	:host host))
	389	(message "Waited (%3ss of %ss) for %s..." total duration resource)
	390	(if (= total duration)
	391	(error "Github is taking too long to create %s" resource)
	392	(if (> total 0)
	393	(let ((wait (min total (- duration total))))
	394	(sit-for wait)
	395	(cl-incf total wait))
	396	(sit-for (setq total 2))))))))
	397
	398	(defun ghub-response-link-relations (req &optional headers payload)
	399	"Return an alist of link relations in HEADERS.
	400	If optional HEADERS is nil, then return those that were
	401	previously stored in the variable `ghub-response-headers'.
	402
	403	When accessing a Bitbucket instance then the link relations
	404	are in PAYLOAD instead of HEADERS, making their API merely
	405	RESTish and forcing this function to append those relations
	406	to the value of `ghub-response-headers', for later use when
	407	this function is called with nil for PAYLOAD."
	408	(if (eq (ghub--req-forge req) 'bitbucket)
	409	(if payload
	410	(let* ((page (cl-mapcan (lambda (key)
	411	(when-let ((elt (assq key payload)))
	412	(list elt)))
	413	'(size page pagelen next previous)))
	414	(headers (cons (cons 'link-alist page) headers)))
	415	(if (and req (or (ghub--req-callback req)
	416	(ghub--req-errorback req)))
	417	(setq-local ghub-response-headers headers)
	418	(setq-default ghub-response-headers headers))
	419	page)
	420	(cdr (assq 'link-alist ghub-response-headers)))
	421	(when-let ((rels (cdr (assoc "Link" (or headers ghub-response-headers)))))
	422	(mapcar (lambda (elt)
	423	(pcase-let ((`(,url ,rel) (split-string elt "; ")))
	424	(cons (intern (substring rel 5 -1))
	425	(substring url 1 -1))))
	426	(split-string rels ", ")))))
	427
	428	(cl-defun ghub-repository-id (owner name &key username auth host forge)
	429	"Return the id of the specified repository."
	430	(let ((fn (intern (format "%s-repository-id" (or forge 'ghub)))))
	431	(funcall (if (eq fn 'ghub-repository-id) 'ghub--repository-id fn)
	432	owner name :username username :auth auth :host host)))
	433
	434	;;;; Internal
	435
	436	(cl-defun ghub--retrieve (payload req)
	437	(let ((url-request-extra-headers
	438	(let ((headers (ghub--req-headers req)))
	439	(if (functionp headers) (funcall headers) headers)))
	440	(url-request-method (ghub--req-method req))
	441	(url-request-data payload)
	442	(url-show-status nil)
	443	(url (ghub--req-url req))
	444	(handler (ghub--req-handler req))
	445	(silent (ghub--req-silent req)))
	446	(if (or (ghub--req-callback req)
	447	(ghub--req-errorback req))
	448	(url-retrieve url handler (list req) silent)
	449	;; When this function has already been called, then it is a
	450	;; no-op. Otherwise it sets `url-registered-auth-schemes' among
	451	;; other things. If we didn't ensure that it has been run, then
	452	;; `url-retrieve-synchronously' would do it, which would cause
	453	;; the value that we let-bind below to be overwritten, and the
	454	;; "default" value to be lost outside the let-binding.
	455	(url-do-setup)
	456	(with-current-buffer
	457	(let ((url-registered-auth-schemes
	458	'(("basic" ghub--basic-auth-errorback . 10))))
	459	(url-retrieve-synchronously url silent))
	460	(funcall handler (car url-callback-arguments) req)))))
	461
	462	(defun ghub--handle-response (status req)
	463	(let ((buffer (current-buffer)))
	464	(unwind-protect
	465	(progn
	466	(set-buffer-multibyte t)
	467	(let* ((unpaginate (ghub--req-unpaginate req))
	468	(headers (ghub--handle-response-headers status req))
	469	(payload (ghub--handle-response-payload req))
	470	(payload (ghub--handle-response-error status payload req))
	471	(value (ghub--handle-response-value payload req))
	472	(next (cdr (assq 'next (ghub-response-link-relations
	473	req headers payload)))))
	474	(when (numberp unpaginate)
	475	(cl-decf unpaginate))
	476	(setf (ghub--req-url req)
	477	(url-generic-parse-url next))
	478	(setf (ghub--req-unpaginate req) unpaginate)
	479	(or (and next
	480	unpaginate
	481	(or (eq unpaginate t)
	482	(> unpaginate 0))
	483	(ghub-continue req))
	484	(let ((callback (ghub--req-callback req))
	485	(errorback (ghub--req-errorback req))
	486	(err (plist-get status :error)))
	487	(cond ((and err errorback)
	488	(funcall errorback err headers status req))
	489	(callback
	490	(funcall callback value headers status req))
	491	(t value))))))
	492	(when (buffer-live-p buffer)
	493	(kill-buffer buffer)))))
	494
	495	(defun ghub--handle-response-headers (status req)
	496	(goto-char (point-min))
	497	(forward-line 1)
	498	(let (headers)
	499	(while (re-search-forward "^\\([^:]*\\): \\(.+\\)"
	500	url-http-end-of-headers t)
	501	(push (cons (match-string 1)
	502	(match-string 2))
	503	headers))
	504	(setq headers (nreverse headers))
	505	(unless url-http-end-of-headers
	506	(error "BUG: missing headers %s" (plist-get status :error)))
	507	(goto-char (1+ url-http-end-of-headers))
	508	(if (and req (or (ghub--req-callback req)
	509	(ghub--req-errorback req)))
	510	(setq-local ghub-response-headers headers)
	511	(setq-default ghub-response-headers headers))
	512	headers))
	513
	514	(defun ghub--handle-response-error (status payload req)
	515	(let ((noerror (ghub--req-noerror req))
	516	(err (plist-get status :error)))
	517	(if err
	518	(if noerror
	519	(if (eq noerror 'return)
	520	payload
	521	(setcdr (last err) (list payload))
	522	nil)
	523	(ghub--signal-error err payload))
	524	payload)))
	525
	526	(defun ghub--signal-error (err &optional payload)
	527	(pcase-let ((`(,symb . ,data) err))
	528	(if (eq symb 'error)
	529	(if (eq (car-safe data) 'http)
	530	(signal 'ghub-http-error
	531	(let ((code (car (cdr-safe data))))
	532	(list code
	533	(nth 2 (assq code url-http-codes))
	534	payload)))
	535	(signal 'ghub-error data))
	536	(signal symb data))))
	537
	538	(defun ghub--handle-response-value (payload req)
	539	(setf (ghub--req-value req)
	540	(nconc (ghub--req-value req)
	541	(if-let ((nested (and (eq (ghub--req-forge req) 'bitbucket)
	542	(assq 'values payload))))
	543	(cdr nested)
	544	payload))))
	545
	546	(defun ghub--handle-response-payload (req)
	547	(funcall (or (ghub--req-reader req)
	548	'ghub--read-json-payload)
	549	url-http-response-status))
	550
	551	(defun ghub--read-json-payload (_status)
	552	(let ((raw (ghub--decode-payload)))
	553	(and raw
	554	(condition-case nil
	555	(let ((json-object-type 'alist)
	556	(json-array-type 'list)
	557	(json-key-type 'symbol)
	558	(json-false nil)
	559	(json-null nil))
	560	(json-read-from-string raw))
	561	(json-readtable-error
	562	`((message
	563	. ,(if (looking-at "<!DOCTYPE html>")
	564	(if (re-search-forward
	565	"<p>\\(?:<strong>\\)?\\([^<]+\\)" nil t)
	566	(match-string 1)
	567	"error description missing")
	568	(string-trim (buffer-substring (point) (point-max)))))
	569	(documentation_url
	570	. "https://github.com/magit/ghub/wiki/Github-Errors")))))))
	571
	572	(defun ghub--decode-payload (&optional _status)
	573	(and (not (eobp))
	574	(decode-coding-string
	575	(buffer-substring-no-properties (point) (point-max))
	576	'utf-8)))
	577
	578	(defun ghub--encode-payload (payload)
	579	(and payload
	580	(progn
	581	(unless (stringp payload)
	582	(setq payload (json-encode-list payload)))
	583	(encode-coding-string payload 'utf-8))))
	584
	585	(defun ghub--url-encode-params (params)
	586	(mapconcat (lambda (param)
	587	(pcase-let ((`(,key . ,val) param))
	588	(concat (url-hexify-string (symbol-name key)) "="
	589	(if (integerp val)
	590	(number-to-string val)
	591	(url-hexify-string val)))))
	592	params "&"))
	593
	594	;;; Authentication
	595	;;;; API
	596
	597	;;;###autoload
	598	(defun ghub-create-token (host username package scopes)
	599	"Create, store and return a new token.
	600
	601	HOST is the Github instance, usually \"api.github.com\".
	602	USERNAME is the name of a user on that instance.
	603	PACKAGE is the package that will use the token.
	604	SCOPES are the scopes the token is given access to."
	605	(interactive
	606	(pcase-let ((`(,host ,username ,package)
	607	(ghub--read-triplet)))
	608	(list host username package
	609	(split-string
	610	(read-string
	611	"Scopes (separated by commas): "
	612	(mapconcat #'symbol-name
	613	(symbol-value
	614	(intern (format "%s-github-token-scopes" package)))
	615	","))
	616	"," t "[\s\t]+"))))
	617	(let ((user (ghub--ident username package)))
	618	(cl-destructuring-bind (save token)
	619	(ghub--auth-source-get (list :save-function :secret)
	620	:create t :host host :user user
	621	:secret
	622	(cdr (assq 'token
	623	(ghub-post
	624	"/authorizations"
	625	`((scopes . ,scopes)
	626	(note . ,(ghub--ident-github package)))
	627	:username username :auth 'basic :host host))))
	628	;; Build-in back-ends return a function that does the actual
	629	;; saving, while for some third-party back-ends ":create t"
	630	;; is enough.
	631	(when (functionp save)
	632	(funcall save))
	633	;; If the Auth-Source cache contains the information that there
	634	;; is no value, then setting the value does not invalidate that
	635	;; now incorrect information.
	636	(auth-source-forget (list :host host :user user))
	637	token)))
	638
	639	;;;###autoload
	640	(defun ghub-token-scopes (host username package)
	641	"Return and echo the scopes of the specified token.
	642	This is intended for debugging purposes only. The user
	643	has to provide several values including their password."
	644	(interactive (ghub--read-triplet))
	645	(let ((scopes
	646	(cdr (assq 'scopes (ghub--get-token-plist host username package)))))
	647	(when (called-interactively-p 'any)
	648	;; Also show the input values to make it easy for package
	649	;; authors to verify that the user has done it correctly.
	650	(message "Scopes for %s@%s: %S"
	651	(ghub--ident username package)
	652	host scopes))
	653	scopes))
	654
	655	;;;###autoload
	656	(defun ghub-clear-caches ()
	657	"Clear all caches that might negatively affect Ghub.
	658
	659	If a library that is used by Ghub caches incorrect information
	660	such as a mistyped password, then that can prevent Ghub from
	661	asking the user for the correct information again.
	662
	663	Set `url-http-real-basic-auth-storage' to nil
	664	and call `auth-source-forget+'."
	665	(interactive)
	666	(setq url-http-real-basic-auth-storage nil)
	667	(auth-source-forget+))
	668
	669	;;;; Internal
	670
	671	(defun ghub--headers (headers host auth username forge)
	672	(push (cons "Content-Type" "application/json") headers)
	673	(if (eq auth 'none)
	674	headers
	675	(unless (or username (stringp auth))
	676	(setq username (ghub--username host forge)))
	677	(lambda ()
	678	(if (eq auth 'basic)
	679	(cons (cons "Authorization" (ghub--basic-auth host username))
	680	headers)
	681	(cons (ghub--auth host auth username forge) headers)))))
	682
	683	(defun ghub--auth (host auth &optional username forge)
	684	(unless username
	685	(setq username (ghub--username host)))
	686	(if (eq auth 'basic)
	687	(cl-ecase forge
	688	((nil github gitea gogs bitbucket)
	689	(cons "Authorization" (ghub--basic-auth host username)))
	690	(gitlab
	691	(error "Gitlab does not support basic authentication")))
	692	(cons (cl-ecase forge
	693	((nil github gitea gogs bitbucket)
	694	"Authorization")
	695	(gitlab
	696	"Private-Token"))
	697	(concat
	698	(and (not (eq forge 'gitlab)) "token ")
	699	(encode-coding-string
	700	(cl-typecase auth
	701	(string auth)
	702	(null (ghub--token host username 'ghub nil forge))
	703	(symbol (ghub--token host username auth nil forge))
	704	(t (signal 'wrong-type-argument
	705	`((or stringp symbolp) ,auth))))
	706	'utf-8)))))
	707
	708	(defun ghub--basic-auth (host username)
	709	(let ((url (url-generic-parse-url (concat "https://" host))))
	710	(setf (url-user url) username)
	711	(url-basic-auth url t)))
	712
	713	(defun ghub--basic-auth-errorback (url &optional prompt _overwrite _realm _args)
	714	;; This gets called twice. Do nothing the first time,
	715	;; when PROMPT is nil. See `url-get-authentication'.
	716	(when prompt
	717	(if (assoc "X-GitHub-OTP" (ghub--handle-response-headers nil nil))
	718	(progn
	719	(setq url-http-extra-headers
	720	`(("Content-Type" . "application/json")
	721	("X-GitHub-OTP" . ,(ghub--read-2fa-code))
	722	;; Without "Content-Type" and "Authorization".
	723	;; The latter gets re-added from the return value.
	724	,@(cddr url-http-extra-headers)))
	725	;; Return the cached values, they are correct.
	726	(url-basic-auth url nil nil nil))
	727	;; Remove the invalid cached values and fail, which
	728	;; is better than the invalid values sticking around.
	729	(setq url-http-real-basic-auth-storage
	730	(cl-delete (format "%s:%d" (url-host url) (url-port url))
	731	url-http-real-basic-auth-storage
	732	:test #'equal :key #'car))
	733	nil)))
	734
	735	(defun ghub--token (host username package &optional nocreate forge)
	736	(let* ((user (ghub--ident username package))
	737	(token
	738	(or (car (ghub--auth-source-get (list :secret)
	739	:host host :user user))
	740	(progn
	741	;; Auth-Source caches the information that there is no
	742	;; value, but in our case that is a situation that needs
	743	;; fixing so we want to keep trying by invalidating that
	744	;; information.
	745	;; The (:max 1) is needed and has to be placed at the
	746	;; end for Emacs releases before 26.1. See #24, #64.
	747	(auth-source-forget (list :host host :user user :max 1))
	748	(and (not nocreate)
	749	(cl-ecase forge
	750	((nil github)
	751	(ghub--confirm-create-token host username package))
	752	((gitlab gitea gogs bitbucket)
	753	(error "Required %s token (%S for %S) does not exist.
	754	See https://magit.vc/manual/ghub/Support-for-Other-Forges.html for instructions."
	755	(capitalize (symbol-name forge))
	756	user host))))))))
	757	(if (functionp token) (funcall token) token)))
	758
	759	(defun ghub--host (&optional forge)
	760	(cl-ecase forge
	761	((nil github)
	762	(or (ignore-errors (car (process-lines "git" "config" "github.host")))
	763	ghub-default-host))
	764	(gitlab
	765	(or (ignore-errors (car (process-lines "git" "config" "gitlab.host")))
	766	(bound-and-true-p glab-default-host)))
	767	(gitea
	768	(or (ignore-errors (car (process-lines "git" "config" "gitea.host")))
	769	(bound-and-true-p gtea-default-host)))
	770	(gogs
	771	(or (ignore-errors (car (process-lines "git" "config" "gogs.host")))
	772	(bound-and-true-p gogs-default-host)))
	773	(bitbucket
	774	(or (ignore-errors (car (process-lines "git" "config" "bitbucket.host")))
	775	(bound-and-true-p buck-default-host)))))
	776
	777	(defun ghub--username (host &optional forge)
	778	(let ((var
	779	(cl-ecase forge
	780	((nil github)
	781	(if (equal host ghub-default-host)
	782	"github.user"
	783	(format "github.%s.user" host)))
	784	(gitlab
	785	(if (equal host "gitlab.com/api/v4")
	786	"gitlab.user"
	787	(format "gitlab.%s.user" host)))
	788	(bitbucket
	789	(if (equal host "api.bitbucket.org/2.0")
	790	"bitbucket.user"
	791	(format "bitbucket.%s.user" host)))
	792	(gitea
	793	(when (zerop (call-process "git" nil nil nil "config" "gitea.host"))
	794	(error "gitea.host is set but always ignored"))
	795	(format "gitea.%s.user" host))
	796	(gogs
	797	(when (zerop (call-process "git" nil nil nil "config" "gogs.host"))
	798	(error "gogs.host is set but always ignored"))
	799	(format "gogs.%s.user" host)))))
	800	(condition-case nil
	801	(car (process-lines "git" "config" var))
	802	(error
	803	(let ((user (read-string
	804	(format "Git variable `%s' is unset. Set to: " var))))
	805	(or (and user (progn (call-process "git" nil nil nil
	806	"config" "--global" var user)
	807	user))
	808	(user-error "Abort")))))))
	809
	810	(defun ghub--ident (username package)
	811	(format "%s^%s" username package))
	812
	813	(defun ghub--ident-github (package)
	814	(format "Emacs package %s @ %s"
	815	package
	816	(or ghub-override-system-name (system-name))))
	817
	818	(defun ghub--package-scopes (package)
	819	(let ((var (intern (format "%s-github-token-scopes" package))))
	820	(if (boundp var)
	821	(symbol-value var)
	822	(error "%s fails to define %s" package var))))
	823
	824	(defun ghub--confirm-create-token (host username package)
	825	(let* ((ident (ghub--ident-github package))
	826	(scopes (ghub--package-scopes package))
	827	(max-mini-window-height 40))
	828	(if (let ((message-log-max nil))
	829	(yes-or-no-p
	830	(format
	831	"Such a Github API token is not available:
	832
	833	Host: %s
	834	User: %s
	835	Package: %s
	836
	837	Scopes requested in `%s-github-token-scopes':\n%s
	838	Store on Github as:\n %S
	839	Store locally according to option `auth-sources':\n %S
	840	%s
	841	If in doubt, then abort and first view the section of
	842	the Ghub documentation called \"Interactively Creating
	843	and Storing a Token\".
	844
	845	Otherwise confirm and then provide your Github username and
	846	password at the next two prompts. Depending on the backend
	847	you might have to provide a passphrase and confirm that you
	848	really want to save the token.
	849
	850	Create and store such a token? "
	851	host username package package
	852	(mapconcat (lambda (scope) (format " %s" scope)) scopes "\n")
	853	ident auth-sources
	854	(if (and (stringp (car auth-sources))
	855	(not (string-suffix-p ".gpg" (car auth-sources))))
	856	(format "
	857	WARNING: The token will be stored unencrypted in %S.
	858	If you don't want that, you have to abort and customize
	859	the `auth-sources' option.\n" (car auth-sources))
	860	""))))
	861	(condition-case ghub--create-token-error
	862	;; Naively attempt to create the token since the user told us to
	863	(ghub-create-token host username package scopes)
	864	;; The API _may_ respond with the fact that a token of the name
	865	;; we wanted already exists. At this point we're out of luck. We
	866	;; don't have a token (otherwise why would we be here?) and, if
	867	;; the user is using SMS 2FA, we have no way of telling GitHub
	868	;; to send a new 2FA code to the user other than sending a POST
	869	;; to /authorizations which is ugly.
	870	;;
	871	;; If they are not using SMS 2FA then we could try to delete the
	872	;; existing token (which will require them to hand us another
	873	;; OTP for the delete request) and then call create again,
	874	;; possibly requiring _another_ OTP if they don't do things fast
	875	;; enough, but this is only because non-SMS 2FA doesn't require
	876	;; any action on GitHub's part.
	877	;;
	878	;; GitHub does hand us a header that indicates what type of 2FA
	879	;; is in use, but it's not currently available in this location
	880	;; and would make the following code which is already quite
	881	;; complicated even more complicated. So in the interest of
	882	;; simplicity it's better to error out here and ask the user to
	883	;; take action. This situation should almost never arise anyway.
	884	(ghub-http-error
	885	(if (string-equal (let-alist (nth 3 ghub--create-token-error)
	886	(car .errors.code))
	887	"already_exists")
	888	(error "\
	889	A token named %S already exists on Github. \
	890	Please visit https://github.com/settings/tokens and delete it." ident))))
	891	(user-error "Abort"))))
	892
	893	(defun ghub--get-token-id (host username package)
	894	(let ((ident (ghub--ident-github package)))
	895	(cl-some (lambda (x)
	896	(let-alist x
	897	(and (equal .app.name ident) .id)))
	898	(ghub-get "/authorizations"
	899	'((per_page . 100))
	900	:unpaginate t
	901	:username username :auth 'basic :host host))))
	902
	903	(defun ghub--get-token-plist (host username package)
	904	(ghub-get (format "/authorizations/%s"
	905	(ghub--get-token-id host username package))
	906	nil :username username :auth 'basic :host host))
	907
	908	(defun ghub--delete-token (host username package)
	909	(ghub-delete (format "/authorizations/%s"
	910	(ghub--get-token-id host username package))
	911	nil :username username :auth 'basic :host host))
	912
	913	(defun ghub--read-triplet ()
	914	(let ((host (read-string "Host: " (ghub--host))))
	915	(list host
	916	(read-string "Username: " (ghub--username host))
	917	(intern (read-string "Package: " "ghub")))))
	918
	919	(defvar ghub--2fa-cache nil)
	920
	921	(defun ghub--read-2fa-code ()
	922	(let ((code (read-number "Two-factor authentication code: "
	923	(and ghub--2fa-cache
	924	(< (float-time (time-subtract
	925	(current-time)
	926	(cdr ghub--2fa-cache)))
	927	25)
	928	(car ghub--2fa-cache)))))
	929	(setq ghub--2fa-cache (cons code (current-time)))
	930	(number-to-string code)))
	931
	932	(defun ghub--auth-source-get (keys &rest spec)
	933	(declare (indent 1))
	934	(let ((plist (car (apply #'auth-source-search
	935	(append spec (list :max 1))))))
	936	(mapcar (lambda (k)
	937	(plist-get plist k))
	938	keys)))
	939
	940	(advice-add 'auth-source-netrc-parse-next-interesting :around
	941	'auth-source-netrc-parse-next-interesting@save-match-data)
	942	(defun auth-source-netrc-parse-next-interesting@save-match-data (fn)
	943	"Save match-data for the benefit of caller `auth-source-netrc-parse-one'.
	944	Without wrapping this function in `save-match-data' the caller
	945	won't see the secret from a line that is followed by a commented
	946	line."
	947	(save-match-data (funcall fn)))
	948
	949	;;; _
	950	(provide 'ghub)
	951	(require 'ghub-graphql)
	952	;;; ghub.el ends here