Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Add package archive fallback mechanism #6828

Closed
wants to merge 5 commits into from
Closed

Add package archive fallback mechanism #6828

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
7996c8a
improve archive availability check
Aug 15, 2016
493eb70
use fallback archive when any archive is down
Aug 18, 2016
eded51e
use list of fallback package archives
Aug 20, 2016
11d5899
store package archive urls in one list
d12frosted Sep 16, 2016
595f5ab
allow to use local package archive urls
d12frosted Sep 16, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
138 changes: 86 additions & 52 deletions core/core-configuration-layer.el
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -20,9 +20,6 @@
(require 'core-funcs)
(require 'core-spacemacs-buffer)

(defvar configuration-layer--refresh-package-timeout dotspacemacs-elpa-timeout
"Timeout in seconds to reach a package archive page.")

(defconst configuration-layer-template-directory
(expand-file-name (concat spacemacs-core-directory "templates/"))
"Configuration layer templates directory.")
Expand Down Expand Up @@ -209,8 +206,16 @@ is not set for the given SLOT."

(defvar configuration-layer--elpa-archives
'(("melpa" . "melpa.org/packages/")
("melpa" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/melpa/")
("melpa" . "elpa.zilongshanren.com/melpa/")

("org" . "orgmode.org/elpa/")
("gnu" . "elpa.gnu.org/packages/"))
("org" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/org/")
("org" . "elpa.zilongshanren.com/org/")

("gnu" . "elpa.gnu.org/packages/")
("gnu" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/gnu/")
("gnu" . "elpa.zilongshanren.com/gnu/"))
"List of ELPA archives required by Spacemacs.")

(defvar configuration-layer-exclude-all-layers nil
Expand Down Expand Up @@ -273,7 +278,6 @@ cache folder.")

(defun configuration-layer/initialize ()
"Initialize `package.el'."
(setq configuration-layer--refresh-package-timeout dotspacemacs-elpa-timeout)
(unless package--initialized
(setq configuration-layer-rollback-directory
(configuration-layer/elpa-directory configuration-layer-rollback-directory))
Expand All @@ -295,41 +299,61 @@ cache folder.")
(configuration-layer/load-or-install-protected-package 'package-build)
(configuration-layer/load-or-install-protected-package 'quelpa))

(defun configuration-layer//resolve-package-archive (archive)
"Resolve HTTP handlers for ARCHIVE.
If the address of an ARCHIVE already contains the protocol then this address is
left untouched."
(cons (car archive)
(if (or (string-match-p "http" (cdr archive))
(string-prefix-p "/" (cdr archive)))
(cdr archive)
(concat (if (and dotspacemacs-elpa-https
(not spacemacs-insecure)
;; for now org ELPA repository does
;; not support HTTPS
;; TODO when org ELPA repo support
;; HTTPS remove the check
;; `(not (equal "org" (car archive)))'
(not (equal "org" (car archive))))
"https://"
"http://")
(cdr archive)))))

(defun configuration-layer//resolve-package-archives (archives)
"Resolve HTTP handlers for each archive in ARCHIVES and return a list
of all reachable ones.
If the address of an archive already contains the protocol then this address is
left untouched.
The returned list has a `package-archives' compliant format."
(mapcar
(lambda (x)
(cons (car x)
(if (or (string-match-p "http" (cdr x))
(string-prefix-p "/" (cdr x)))
(cdr x)
(concat
(if (and dotspacemacs-elpa-https
(not spacemacs-insecure)
;; for now org ELPA repository does
;; not support HTTPS
;; TODO when org ELPA repo support
;; HTTPS remove the check
;; `(not (equal "org" (car x)))'
(not (equal "org" (car x))))
"https://"
"http://")
(cdr x)))))
archives))
(mapcar 'configuration-layer//resolve-package-archive archives))

(defun configuration-layer//check-archive-status (archive)
"Check ARCHIVE status.

Available return values are available and unavailable."
(let ((url (format "%sarchive-contents"
(cdr (assoc archive package-archives))))
(state 'unavailable))
(condition-case nil
(when (or (and (string-prefix-p "/" url)
(file-readable-p url))
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Not sure that this is the best way of checking that archive url is accessible. file-accessible-directory-p? I haven't tested situations when archive-contents file is readable, but all other files are not readable by current user.

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@d12frosted Where can we find the documentation about file-readable-p capable of checking URLs except in the C source ? This function does not block for a long time when the URL is not reachable ? What kind of tests did you do to check that file-readable-p is not blocking for a long time ?

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

What kind of tests did you do to check that file-readable-p is not blocking for a long time ?

I mean, did you test regular timeout method and file-readable-p with the same input ?

(url-http-file-exists-p url))
(setq state 'available))
((error) (setq state 'unavailable)))
state))

(defun configuration-layer//get-available-archive-url (archive)
(if (eq 'available (configuration-layer//check-archive-status archive))
(cdr (assoc archive package-archives))
(setq package-archives
(delq (assoc archive package-archives) package-archives))
(when (assoc archive package-archives)
(configuration-layer//get-available-archive-url archive))))

(defun configuration-layer/retrieve-package-archives (&optional quiet force)
"Retrieve all archives declared in current `package-archives'.

This function first performs a simple GET request with a timeout in order to
fix very long refresh time when an archive is not reachable.

Note that this simple GET is a heuristic to determine the availability
likelihood of an archive, so it can gives false positive if the archive
page is served but the archive is not.
This function first checks that all archives are available.

If QUIET is non nil then the function does not print message in the Spacemacs
home buffer.
Expand All @@ -348,26 +372,36 @@ refreshed during the current session."
(car archive) i count) t))
(spacemacs//redisplay)
(setq i (1+ i))
(unless (eq 'error
(with-timeout
(dotspacemacs-elpa-timeout
(progn
(display-warning
'spacemacs
(format
"\nError connection time out for %s repository!"
(car archive)) :warning)
'error))
(condition-case err
(url-retrieve-synchronously (cdr archive))
('error
(display-warning 'spacemacs
(format
"\nError while contacting %s repository!"
(car archive)) :warning)
'error))))
(let ((package-archives (list archive)))
(package-refresh-contents))))
(setcdr archive
(configuration-layer//get-available-archive-url (car archive)))
(unless (cdr archive)
(error "Archive '%s' and all it's mirrors are not
available. Please verify that you have internet connection and
you are able to connect to any of the following URLs:

%s

If this is your first launch of Spacemacs you have to be
connected to internet as Spacemacs must install some third-party
packages in order to function properly. If it's not your first
launch of Spacemacs most probably you asked Spacemacs to install
new third-party packages (e. g. by editing
`dotspacemacs-additional-packages', editing list of packages of
any layer or enabling new layer). In such case you also must be
connected to internet. In case you can't, please revert your
changes that forced Spacemacs to install new packages."
(car archive)
(mapconcat 'identity
(mapcar
#'cdr
(mapcar
#'configuration-layer//resolve-package-archive
(remove-if-not
(lambda (obj) (string-equal (car obj) (car archive)))
configuration-layer--elpa-archives)))
"\n")))
(let ((package-archives (list archive)))
(package-refresh-contents)))
(package-read-all-archive-contents)
(unless quiet (spacemacs-buffer/append "\n")))))

Expand Down Expand Up @@ -1971,8 +2005,8 @@ to select one."
(cadr (assq 'built-in stats))))
(with-current-buffer (get-buffer-create spacemacs-buffer-name)
(let ((buffer-read-only nil))
(spacemacs-buffer//center-line)
(insert "\n")))))
(spacemacs-buffer//center-line)
(insert "\n")))))

(defun configuration-layer/load-or-install-protected-package
(pkg &optional log file-to-load)
Expand Down
3 changes: 0 additions & 3 deletions core/core-dotspacemacs.el
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -60,9 +60,6 @@ or `spacemacs'.")
possible. Set it to nil if you have no way to use HTTPS in your
environment, otherwise it is strongly recommended to let it set to t.")

(defvar dotspacemacs-elpa-timeout 5
"Maximum allowed time in seconds to contact an ELPA repository.")

(defvar dotspacemacs-elpa-subdirectory nil
"If non-nil, a form that evaluates to a package directory. For
example, to use different package directories for different Emacs
Expand Down
16 changes: 5 additions & 11 deletions tests/core/core-configuration-layer-utest.el
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -197,18 +197,10 @@
;; configuration-layer/retrieve-package-archives
;; ---------------------------------------------------------------------------

(ert-deftest test-retrieve-package-archives--catch-time-out-error ()
(let ((package-archives '(("gnu" . "https://elpa.gnu.org/packages/")))
(configuration-layer--package-archives-refreshed nil)
(dotspacemacs-elpa-timeout -1))
(mocker-let
((message (format-string &rest args)
((:record-cls 'mocker-stub-record :output nil))))
(configuration-layer/retrieve-package-archives))))

(ert-deftest test-retrieve-package-archives--catch-connection-errors ()
(let ((package-archives '(("gnu" . "https://elpa.gnu.org/packages/")))
(configuration-layer--package-archives-refreshed nil))
(configuration-layer--package-archives-refreshed nil)
(configuration-layer-fallback-package-archives nil))
(cl-letf (((symbol-function 'url-retrieve-synchronously)
(lambda (x)
(signal 'file-error '("make client process failed"
Expand All @@ -219,7 +211,9 @@
:service 443
:nowait nil))))
((symbol-function 'message) 'ignore))
(configuration-layer/retrieve-package-archives))))
(should-error
(configuration-layer/retrieve-package-archives)
:type 'error))))

;; ---------------------------------------------------------------------------
;; configuration-layer//select-packages
Expand Down