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, 0 insertions, 912 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 deleted file mode 100644 index 6d9ce8275576..000000000000 --- a/configs/shared/emacs/.emacs.d/elpa/ghub-20180911.1858/ghub.el +++ /dev/null @@ -1,912 +0,0 @@ -;;; 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 |