mirror of https://github.com/Chizi123/.emacs.d.git

Chizi123
2018-11-18 434b46beff1c5ec01cbefd5273d89971a82d6bab
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