375 lines
15 KiB
EmacsLisp
375 lines
15 KiB
EmacsLisp
;;; paradox-github.el --- interacting with the Github API -*- lexical-binding:t -*-
|
||
|
||
;; Copyright (C) 2014-2015 Artur Malabarba <bruce.connor.am@gmail.com>
|
||
|
||
;; Author: Artur Malabarba <bruce.connor.am@gmail.com>
|
||
;; Prefix: paradox
|
||
;; Separator: -
|
||
|
||
;;; License:
|
||
;;
|
||
;; This file is NOT part of GNU Emacs.
|
||
;;
|
||
;; This program 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 2
|
||
;; of the License, or (at your option) any later version.
|
||
;;
|
||
;; This program 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.
|
||
;;
|
||
|
||
|
||
;;; Code:
|
||
(require 'cl-lib)
|
||
(require 'package)
|
||
(require 'paradox-core)
|
||
|
||
(defgroup paradox-github nil
|
||
"Paradox Github configurations."
|
||
:prefix "paradox-"
|
||
:package-version '(paradox . "2.0")
|
||
:group 'paradox)
|
||
|
||
(defvar paradox--user-starred-list nil)
|
||
(make-obsolete-variable
|
||
'paradox--user-starred-list 'paradox--user-starred-repos "2.1")
|
||
(defvar paradox--user-starred-repos (make-hash-table))
|
||
|
||
|
||
;;; Github token
|
||
(defcustom paradox-github-token nil
|
||
"Access token to use for github actions.
|
||
Currently, that means (un)starring repos.
|
||
|
||
To generate an access token:
|
||
1. Visit the page https://github.com/settings/tokens/new?scopes=public_repo&description=Paradox
|
||
and login to github (if asked).
|
||
2. Click on \"Generate Token\", copy the generated token, and
|
||
save it to this variable by writing
|
||
(setq paradox-github-token TOKEN)
|
||
somewhere in your configuration and evaluating it (or just
|
||
restart emacs).
|
||
|
||
This is similar to how erc or jabber handle authentication in
|
||
emacs, but the following disclaimer always worth reminding.
|
||
|
||
DISCLAIMER
|
||
When you save this variable, DON'T WRITE IT ANYWHERE PUBLIC. This
|
||
token grants (very) limited access to your account.
|
||
END DISCLAIMER
|
||
|
||
Paradox will ask you whether you want github integration the
|
||
first time you start it. If you answer \"no\", it will remember
|
||
your choice via `customize-save-variable'. You can do this
|
||
manually by setting this variable to t. Setting it to nil means
|
||
it hasn't been configured yet."
|
||
:type '(choice (string :tag "Token")
|
||
(const :tag "Disable" t)
|
||
(const :tag "Ask me next time" nil))
|
||
:group 'paradox-github
|
||
:package-version '(paradox . "0.2"))
|
||
|
||
(defcustom paradox-automatically-star 'unconfigured
|
||
"When you install new packages, should they be automatically starred?
|
||
This variable has no effect if `paradox-github-token' isn't set
|
||
to a string.
|
||
|
||
Paradox is capable of automatically starring packages when you
|
||
install them, and unstarring when you delete them. This only
|
||
applies to actual installation/deletion, i.e. Paradox doesn't
|
||
auto (un)star packages that were simply upgraded.
|
||
|
||
If this variable is nil, this behaviour is disabled. \\<paradox-menu-mode-map>
|
||
|
||
On the Package Menu, you can always manually star packages with \\[paradox-menu-mark-star-unstar]."
|
||
:type '(choice (const :tag "Yes" t)
|
||
(const :tag "No" nil)
|
||
(const :tag "Ask later" unconfigured))
|
||
:group 'paradox-github
|
||
:package-version '(paradox . "0.2"))
|
||
|
||
(defmacro paradox--enforce-github-token (&rest forms)
|
||
"If a token is defined, perform FORMS, otherwise ignore forms ask for it be defined."
|
||
`(if (stringp paradox-github-token)
|
||
(progn ,@forms)
|
||
(setq paradox-github-token nil)
|
||
(paradox--check-github-token)))
|
||
|
||
(defun paradox--check-github-token ()
|
||
"Check that the user has either set or refused the github token.
|
||
If neither has happened, ask the user now whether he'd like to
|
||
configure or refuse the token."
|
||
(if (stringp paradox-github-token) t
|
||
(if paradox-github-token
|
||
t
|
||
(if (not (y-or-n-p "Would you like to set up GitHub integration?
|
||
This will allow you to star/unstar packages from the Package Menu. "))
|
||
(customize-save-variable 'paradox-github-token t)
|
||
(describe-variable 'paradox-github-token)
|
||
(when (get-buffer "*Help*")
|
||
(switch-to-buffer "*Help*")
|
||
(delete-other-windows))
|
||
(if (y-or-n-p "Follow the instructions on the `paradox-github-token' variable.
|
||
May I take you to the token generation page? ")
|
||
(browse-url "https://github.com/settings/tokens/new?scopes=public_repo&description=Paradox"))
|
||
(message "Once you're finished, simply call `paradox-list-packages' again.")
|
||
nil))))
|
||
|
||
|
||
;;; Starring
|
||
(defun paradox-star-all-installed-packages ()
|
||
"Star all of your currently installed packages.
|
||
No questions asked."
|
||
(interactive)
|
||
(paradox--enforce-github-token
|
||
(mapc (lambda (x) (paradox--star-package-safe (car-safe x))) package-alist)))
|
||
|
||
(defun paradox--starred-repo-p (repo)
|
||
"Non-nil if REPO is starred by the user."
|
||
(gethash repo paradox--user-starred-repos))
|
||
|
||
(defun paradox--star-package-safe (pkg &optional delete query)
|
||
"Star PKG without throwing errors, unless DELETE is non-nil, then unstar.
|
||
If QUERY is non-nil, ask the user first."
|
||
(let ((repo (gethash pkg paradox--package-repo-list)))
|
||
(when (and repo (paradox--starred-repo-p repo))
|
||
(paradox--star-repo repo delete query))))
|
||
|
||
(defun paradox--star-repo (repo &optional delete query)
|
||
"Star REPO, unless DELETE is non-nil, then unstar.
|
||
If QUERY is non-nil, ask the user first.
|
||
|
||
Throws error if repo is malformed."
|
||
(when (or (not query)
|
||
(y-or-n-p (format "Really %sstar %s? "
|
||
(if delete "un" "") repo)))
|
||
(paradox--github-action-star repo delete)
|
||
(message "%starred %s." (if delete "Uns" "S") repo)
|
||
(if delete
|
||
(remhash repo paradox--user-starred-repos)
|
||
(puthash repo t paradox--user-starred-repos))))
|
||
|
||
(defun paradox--unstar-repo (repo &optional delete query)
|
||
"Unstar REPO.
|
||
Calls (paradox--star-repo REPO (not DELETE) QUERY)."
|
||
(paradox--star-repo repo (not delete) query))
|
||
|
||
(defun paradox--full-name-reader ()
|
||
"Return all \"full_name\" properties in the buffer.
|
||
Much faster than `json-read'."
|
||
(let (out)
|
||
(while (search-forward-regexp
|
||
"^ *\"full_name\" *: *\"\\(.*\\)\", *$" nil t)
|
||
(push (match-string-no-properties 1) out))
|
||
(goto-char (point-max))
|
||
out))
|
||
|
||
(defun paradox--refresh-user-starred-list (&optional async)
|
||
"Fetch the user's list of starred repos."
|
||
(paradox--github-action "user/starred?per_page=100"
|
||
:async (when async 'refresh)
|
||
:callback (lambda (res)
|
||
(setq paradox--user-starred-repos
|
||
(make-hash-table :size (length res)
|
||
:test #'equal))
|
||
(dolist (it res)
|
||
(puthash it t paradox--user-starred-repos)))
|
||
:reader #'paradox--full-name-reader))
|
||
|
||
(defun paradox--github-action-star (repo &optional delete)
|
||
"Call `paradox--github-action' with \"user/starred/REPO\" as the action.
|
||
DELETE and NO-RESULT are passed on."
|
||
(paradox--github-action (concat "user/starred/" repo)
|
||
:async t
|
||
:method (if (stringp delete) delete
|
||
(if delete "DELETE" "PUT"))))
|
||
|
||
|
||
;;; The Base (generic) function
|
||
(defun paradox--github-report (&rest text)
|
||
"Write TEXT to the *Paradox Github* buffer."
|
||
(with-current-buffer (get-buffer-create "*Paradox Report*")
|
||
(let ((inhibit-read-only t))
|
||
(erase-buffer)
|
||
(apply #'insert text))
|
||
(goto-char (point-min))))
|
||
|
||
(defun paradox--github-error (format &rest args)
|
||
"Throw an error using FORMAT and ARGS.
|
||
Also print contents of current buffer to *Paradox Github*."
|
||
(declare (indent 1))
|
||
(paradox--github-report (buffer-string))
|
||
(apply #'error
|
||
(concat format " See *Paradox Github* buffer for the full result")
|
||
args))
|
||
|
||
(defvar paradox--github-errors-to-ignore nil
|
||
"List of numbers to ignore when parsing the HTML return code.
|
||
`paradox--github-parse-response-code' normally returns nil on
|
||
200, t on 204, and emits messages or errors on other values.
|
||
Adding values to this list makes them be treated as a 200.")
|
||
|
||
(defun paradox--github-parse-response-code ()
|
||
"Non-nil if this reponse buffer looks ok.
|
||
Leave point at the return code on the first line."
|
||
(goto-char (point-min))
|
||
(unless (search-forward " " nil t)
|
||
(paradox--github-report (buffer-string))
|
||
(error "Tried contacting Github, but I can't understand the result. See *Paradox Github* buffer for the full result"))
|
||
(pcase (thing-at-point 'number)
|
||
((pred (lambda (n) (member n paradox--github-errors-to-ignore))) nil)
|
||
(`204 nil) ;; OK, but no content.
|
||
(`200 t) ;; OK, with content.
|
||
;; I'll implement redirection if anyone ever reports this.
|
||
;; For now, I haven't found a place where it's used.
|
||
((or `301 `302 `303 `304 `305 `306 `307)
|
||
(paradox--github-report "Redirect received:\n\n" (buffer-string))
|
||
;; (message "Received a redirect reply, please file a bug report (M-x `paradox-bug-report')")
|
||
nil)
|
||
((or `404) ;; Not found.
|
||
(paradox--github-report (buffer-string))
|
||
(message "This repo doesn't seem to exist, Github replied with: %s"
|
||
(substring (thing-at-point 'line) 0 -1))
|
||
nil)
|
||
((or `403) ;; Forbidden
|
||
(paradox--github-error
|
||
"Github wouldn't let me do this - does your token have the right permissions? They're here: https://github.com/settings/tokens"))
|
||
((or `400 `422) ;; Bad request.
|
||
(paradox--github-error
|
||
"Github didn't understand my request, please file a bug report (M-x `paradox-bug-report')"))
|
||
(`401 (paradox--github-error
|
||
(if (stringp paradox-github-token)
|
||
"Github says you're not authenticated, try creating a new Github token"
|
||
"Github says you're not authenticated, you need to configure `paradox-github-token'")))
|
||
(_ (paradox--github-error "Github returned: %S"
|
||
(substring (thing-at-point 'line) 0 -1)))))
|
||
|
||
(defvar paradox--github-next-page nil)
|
||
|
||
(defmacro paradox--with-github-buffer (method action async unwind-form
|
||
&rest body)
|
||
"Run BODY in a Github request buffer.
|
||
UNWIND-FORM is run no matter what, and doesn't affect the return
|
||
value."
|
||
(declare (indent 4)
|
||
(debug t))
|
||
(let ((call-name (make-symbol "callback")))
|
||
`(let ((,call-name
|
||
(lambda (&optional process event)
|
||
(cond
|
||
((or (not event)
|
||
(string-match "\\`finished" event))
|
||
(with-current-buffer (if (processp process)
|
||
(process-buffer process)
|
||
(current-buffer))
|
||
(unwind-protect
|
||
(when (paradox--github-parse-response-code)
|
||
(let ((next-page))
|
||
(when (search-forward-regexp
|
||
"^Link: .*<\\([^>]+\\)>; rel=\"next\"" nil t)
|
||
(setq next-page (match-string-no-properties 1))
|
||
(setq paradox--github-next-page next-page))
|
||
(ignore next-page)
|
||
(search-forward-regexp "^\r?$")
|
||
(skip-chars-forward "[:blank:]\n\r")
|
||
(delete-region (point-min) (point))
|
||
,@body))
|
||
,unwind-form
|
||
(kill-buffer (current-buffer)))))
|
||
((string-match "\\`exited abnormally" event)
|
||
,unwind-form
|
||
(paradox--github-report (buffer-string))
|
||
(message "async curl command %s\n method: %s\n action: %s"
|
||
event ,method ,action))))))
|
||
(if ,async
|
||
(condition-case nil
|
||
(set-process-sentinel
|
||
(apply #'start-process "paradox-github"
|
||
(generate-new-buffer "*Paradox http*")
|
||
"curl" "-s" "-i" "-d" "" "-X" ,method ,action
|
||
(when (stringp paradox-github-token)
|
||
(list "-u" (concat paradox-github-token ":x-oauth-basic"))))
|
||
,call-name)
|
||
(error ,unwind-form))
|
||
(with-temp-buffer
|
||
;; Make the request.
|
||
(condition-case nil
|
||
(apply #'call-process
|
||
"curl" nil t nil "-s" "-i" "-d" "" "-X" ,method ,action
|
||
(when (stringp paradox-github-token)
|
||
(list "-u" (concat paradox-github-token ":x-oauth-basic"))))
|
||
(error ,unwind-form))
|
||
;; Do the processing.
|
||
(funcall ,call-name))))))
|
||
|
||
(cl-defun paradox--github-action (action &key
|
||
(method "GET")
|
||
reader
|
||
max-pages
|
||
(callback #'identity)
|
||
async)
|
||
"Contact the github api performing ACTION with METHOD.
|
||
Default METHOD is \"GET\".
|
||
|
||
Action can be anything such as \"user/starred?per_page=100\". If
|
||
it's not a full url, it will be prepended with
|
||
\"https://api.github.com/\". The action might not work if
|
||
`paradox-github-token' isn't set.
|
||
|
||
This function also handles the pagination used in github results,
|
||
results of each page are appended together. Use MAX-PAGES to
|
||
limit the number of pages that are fetched.
|
||
|
||
Return value is always a list.
|
||
- If READER is nil, the result of the action is completely
|
||
ignored (no pagination is performed on this case, making it
|
||
much faster).
|
||
- Otherwise, READER is called as a function with point right
|
||
after the headers and should always return a list. As a special
|
||
exception, if READER is t, it is equivalent to a function that
|
||
returns (t).
|
||
|
||
CALLBACK, if provided, is a function to be called with the read
|
||
data as an argument. If the request succeeds with no data, it
|
||
will be given nil as an argument. Its return value is returned by
|
||
this function.
|
||
|
||
ASYNC determines to run the command asynchronously. In this case,
|
||
the function's return value is undefined. In particular, if ASYNC
|
||
is the symbol refresh, it means the package-menu should be
|
||
refreshed after the operation is done."
|
||
(declare (indent 1))
|
||
;; Make sure the token's configured.
|
||
(unless (string-match "\\`https?://" action)
|
||
(setq action (concat "https://api.github.com/" action)))
|
||
(let ((do-update (when (eq async 'refresh)
|
||
(make-symbol "paradox-github"))))
|
||
(when do-update
|
||
(add-to-list 'package--downloads-in-progress do-update))
|
||
(paradox--with-github-buffer method action async
|
||
(paradox--update-downloads-in-progress
|
||
do-update)
|
||
(cond
|
||
((not reader)
|
||
(funcall callback nil))
|
||
((or (not next-page)
|
||
(and max-pages (< max-pages 2)))
|
||
(funcall callback
|
||
(unless (eobp) (funcall reader))))
|
||
(t
|
||
(let ((result (unless (eobp) (funcall reader))))
|
||
(paradox--github-action next-page
|
||
:method method
|
||
:reader reader
|
||
:async async
|
||
:max-pages (when max-pages (1- max-pages))
|
||
:callback (lambda (res)
|
||
(funcall callback
|
||
(append result res))))))))))
|
||
|
||
(provide 'paradox-github)
|
||
;;; paradox-github.el ends here
|