From 7996c8aac29f2d08ed96c7af662eb3a52896b287 Mon Sep 17 00:00:00 2001 From: d12frosted Date: Mon, 15 Aug 2016 20:40:30 +0300 Subject: [PATCH 1/5] improve archive availability check --- core/core-configuration-layer.el | 59 ++++++++++---------- core/core-dotspacemacs.el | 3 - tests/core/core-configuration-layer-utest.el | 13 +---- 3 files changed, 34 insertions(+), 41 deletions(-) diff --git a/core/core-configuration-layer.el b/core/core-configuration-layer.el index c7775843c08f..deabbf832adf 100644 --- a/core/core-configuration-layer.el +++ b/core/core-configuration-layer.el @@ -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.") @@ -213,6 +210,12 @@ is not set for the given SLOT." ("gnu" . "elpa.gnu.org/packages/")) "List of ELPA archives required by Spacemacs.") +(defvar configuration-layer--elpa-archives-status + '(("melpa" . unknown) + ("org" . unknown) + ("gnu" . unknown)) + "Status of ELPA archives.") + (defvar configuration-layer-exclude-all-layers nil "If non nil then only the distribution layer is loaded.") @@ -273,7 +276,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)) @@ -324,12 +326,7 @@ The returned list has a `package-archives' compliant format." (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. @@ -348,24 +345,11 @@ 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)))) + (if (eq 'unavailable + (configuration-layer-check-archive-status (car archive))) + (error "Archive '%s' is not available. Please verify +that you have internet connection and you are able to connect to +%s." (car archive) (cdr archive)) (let ((package-archives (list archive))) (package-refresh-contents)))) (package-read-all-archive-contents) @@ -2016,6 +2000,25 @@ FILE-TO-LOAD is an explicit file to load after the installation." (1+ configuration-layer-error-count)) (setq configuration-layer-error-count 1))) +(defun configuration-layer-check-archive-status (archive &optional recheck) + "Check ARCHIVE status. + +By default status is checked only when current status of ARCHIVE +is `unknown'. Check is forced when RECHECK is non-nil." + (let* ((obj (assoc archive configuration-layer--elpa-archives-status)) + (state (cdr obj)) + (url (cdr (assoc archive package-archives)))) + (message "archive %s state %s url %s" archive state url) + (when (and (or (eq state 'unknown) recheck) + url) + (condition-case nil + (if (url-http-file-exists-p url) + (setq state 'available) + (setq state 'unavailable)) + ((error) (setq state 'unavailable))) + (setcdr (assoc archive configuration-layer--elpa-archives-status) state)) + state)) + (provide 'core-configuration-layer) ;;; core-configuration-layer.el ends here diff --git a/core/core-dotspacemacs.el b/core/core-dotspacemacs.el index 9cfa2617ef2a..b0147bc627b7 100644 --- a/core/core-dotspacemacs.el +++ b/core/core-dotspacemacs.el @@ -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 diff --git a/tests/core/core-configuration-layer-utest.el b/tests/core/core-configuration-layer-utest.el index cd9355356598..caee2fd3444d 100644 --- a/tests/core/core-configuration-layer-utest.el +++ b/tests/core/core-configuration-layer-utest.el @@ -197,15 +197,6 @@ ;; 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)) @@ -219,7 +210,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 From 493eb709a4b7a3bc41f9fef796ae0dfd8e5999ea Mon Sep 17 00:00:00 2001 From: d12frosted Date: Thu, 18 Aug 2016 21:24:22 +0300 Subject: [PATCH 2/5] use fallback archive when any archive is down --- core/core-configuration-layer.el | 62 +++++++++++++++++++------------- 1 file changed, 38 insertions(+), 24 deletions(-) diff --git a/core/core-configuration-layer.el b/core/core-configuration-layer.el index deabbf832adf..c58165262ac4 100644 --- a/core/core-configuration-layer.el +++ b/core/core-configuration-layer.el @@ -216,6 +216,13 @@ is not set for the given SLOT." ("gnu" . unknown)) "Status of ELPA archives.") +(defvar configuration-layer-fallback-package-archive + "elpa.zilongshanren.com" + "URL of fallback package archive. + +This archive is used when one of archives is down for any +reason.") + (defvar configuration-layer-exclude-all-layers nil "If non nil then only the distribution layer is loaded.") @@ -297,31 +304,33 @@ 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 x)) + (string-prefix-p "/" (cdr x))) + (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/retrieve-package-archives (&optional quiet force) "Retrieve all archives declared in current `package-archives'. @@ -347,9 +356,14 @@ refreshed during the current session." (setq i (1+ i)) (if (eq 'unavailable (configuration-layer-check-archive-status (car archive))) - (error "Archive '%s' is not available. Please verify -that you have internet connection and you are able to connect to -%s." (car archive) (cdr archive)) + (setcdr + (assoc (car archive) package-archives) + (cdr + (configuration-layer//resolve-package-archive + (cons (car archive) + (format "%s/%s/" + configuration-layer-fallback-package-archive + (car archive)))))) (let ((package-archives (list archive))) (package-refresh-contents)))) (package-read-all-archive-contents) @@ -1955,8 +1969,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) From eded51ef3749d37ba0dbcc14945a064b2d42bdd9 Mon Sep 17 00:00:00 2001 From: d12frosted Date: Sat, 20 Aug 2016 13:39:16 +0300 Subject: [PATCH 3/5] use list of fallback package archives Instead of using one fallback url, use package-archives compatible list of fallback urls. If currently set url is not reachable, then try to connect to one of fallback urls. If all urls are unavailable - show an error with some hints and explanations. --- core/core-configuration-layer.el | 99 +++++++++++++------- tests/core/core-configuration-layer-utest.el | 3 +- 2 files changed, 66 insertions(+), 36 deletions(-) diff --git a/core/core-configuration-layer.el b/core/core-configuration-layer.el index c58165262ac4..36189445f38d 100644 --- a/core/core-configuration-layer.el +++ b/core/core-configuration-layer.el @@ -216,8 +216,15 @@ is not set for the given SLOT." ("gnu" . unknown)) "Status of ELPA archives.") -(defvar configuration-layer-fallback-package-archive - "elpa.zilongshanren.com" +(defvar configuration-layer-fallback-package-archives + '(("melpa" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/melpa/") + ("melpa" . "elpa.zilongshanren.com/melpa/") + + ("org" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/org/") + ("org" . "elpa.zilongshanren.com/org/") + + ("gnu" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/gnu/") + ("gnu" . "elpa.zilongshanren.com/gnu/")) "URL of fallback package archive. This archive is used when one of archives is down for any @@ -309,8 +316,8 @@ cache folder.") 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 x)) - (string-prefix-p "/" (cdr x))) + (if (or (string-match-p "http" (cdr archive)) + (string-prefix-p "/" (cdr archive))) (cdr archive) (concat (if (and dotspacemacs-elpa-https (not spacemacs-insecure) @@ -332,6 +339,37 @@ left untouched. The returned list has a `package-archives' compliant format." (mapcar 'configuration-layer//resolve-package-archive archives)) +(defun configuration-layer//check-archive-status (archive &optional recheck) + "Check ARCHIVE status. + +By default status is checked only when current status of ARCHIVE +is `unknown'. Check is forced when RECHECK is non-nil." + (let* ((obj (assoc archive configuration-layer--elpa-archives-status)) + (state (cdr obj)) + (url (format "%sarchive-contents" (cdr (assoc archive package-archives))))) + (when (and (or (eq state 'unknown) recheck) + url) + (condition-case nil + (if (url-http-file-exists-p url) + (setq state 'available) + (setq state 'unavailable)) + ((error) (setq state 'unavailable))) + (setcdr (assoc archive configuration-layer--elpa-archives-status) state)) + (message "archive '%s' at %s is %s" archive url state) + state)) + +(defun configuration-layer//get-available-archive-url (archive) + (if (eq 'available (configuration-layer//check-archive-status archive t)) + (cdr (assoc archive package-archives)) + (let ((obj (assoc archive configuration-layer-fallback-package-archives))) + (when obj + (setcdr + (assoc archive package-archives) + (cdr (configuration-layer//resolve-package-archive obj))) + (setq configuration-layer-fallback-package-archives + (delq obj configuration-layer-fallback-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'. @@ -354,18 +392,28 @@ refreshed during the current session." (car archive) i count) t)) (spacemacs//redisplay) (setq i (1+ i)) - (if (eq 'unavailable - (configuration-layer-check-archive-status (car archive))) - (setcdr - (assoc (car archive) package-archives) - (cdr - (configuration-layer//resolve-package-archive - (cons (car archive) - (format "%s/%s/" - configuration-layer-fallback-package-archive - (car archive)))))) - (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 %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) + (cdr + (configuration-layer//resolve-package-archive + (assoc (car archive) configuration-layer--elpa-archives))))) + (let ((package-archives (list archive))) + (package-refresh-contents))) (package-read-all-archive-contents) (unless quiet (spacemacs-buffer/append "\n"))))) @@ -2014,25 +2062,6 @@ FILE-TO-LOAD is an explicit file to load after the installation." (1+ configuration-layer-error-count)) (setq configuration-layer-error-count 1))) -(defun configuration-layer-check-archive-status (archive &optional recheck) - "Check ARCHIVE status. - -By default status is checked only when current status of ARCHIVE -is `unknown'. Check is forced when RECHECK is non-nil." - (let* ((obj (assoc archive configuration-layer--elpa-archives-status)) - (state (cdr obj)) - (url (cdr (assoc archive package-archives)))) - (message "archive %s state %s url %s" archive state url) - (when (and (or (eq state 'unknown) recheck) - url) - (condition-case nil - (if (url-http-file-exists-p url) - (setq state 'available) - (setq state 'unavailable)) - ((error) (setq state 'unavailable))) - (setcdr (assoc archive configuration-layer--elpa-archives-status) state)) - state)) - (provide 'core-configuration-layer) ;;; core-configuration-layer.el ends here diff --git a/tests/core/core-configuration-layer-utest.el b/tests/core/core-configuration-layer-utest.el index caee2fd3444d..d197b4a3d8a0 100644 --- a/tests/core/core-configuration-layer-utest.el +++ b/tests/core/core-configuration-layer-utest.el @@ -199,7 +199,8 @@ (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" From 11d589953fffa246f4d6598311c24128c1d0e63c Mon Sep 17 00:00:00 2001 From: d12frosted Date: Fri, 16 Sep 2016 18:14:05 +0300 Subject: [PATCH 4/5] store package archive urls in one list Instead of storing fallback urls for package archives in separate variable and doing complicated operations in order to derive available url, store all urls (official and fallback ones) in `configuration-layer--elpa-archives`. This simplifies availability check and user configurations. Also get rid of `configuration-layer--elpa-archives-status` as it's really not used. --- core/core-configuration-layer.el | 87 ++++++++++++++------------------ 1 file changed, 37 insertions(+), 50 deletions(-) diff --git a/core/core-configuration-layer.el b/core/core-configuration-layer.el index 36189445f38d..f223e5b00579 100644 --- a/core/core-configuration-layer.el +++ b/core/core-configuration-layer.el @@ -206,29 +206,17 @@ is not set for the given SLOT." (defvar configuration-layer--elpa-archives '(("melpa" . "melpa.org/packages/") - ("org" . "orgmode.org/elpa/") - ("gnu" . "elpa.gnu.org/packages/")) - "List of ELPA archives required by Spacemacs.") - -(defvar configuration-layer--elpa-archives-status - '(("melpa" . unknown) - ("org" . unknown) - ("gnu" . unknown)) - "Status of ELPA archives.") - -(defvar configuration-layer-fallback-package-archives - '(("melpa" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/melpa/") + ("melpa" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/melpa/") ("melpa" . "elpa.zilongshanren.com/melpa/") - ("org" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/org/") - ("org" . "elpa.zilongshanren.com/org/") - - ("gnu" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/gnu/") - ("gnu" . "elpa.zilongshanren.com/gnu/")) - "URL of fallback package archive. + ("org" . "orgmode.org/elpa/") + ("org" . "raw.githubusercontent.com/syl20bnr/spacemacs-elpa-mirror/master/org/") + ("org" . "elpa.zilongshanren.com/org/") -This archive is used when one of archives is down for any -reason.") + ("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 "If non nil then only the distribution layer is loaded.") @@ -339,36 +327,27 @@ left untouched. The returned list has a `package-archives' compliant format." (mapcar 'configuration-layer//resolve-package-archive archives)) -(defun configuration-layer//check-archive-status (archive &optional recheck) +(defun configuration-layer//check-archive-status (archive) "Check ARCHIVE status. -By default status is checked only when current status of ARCHIVE -is `unknown'. Check is forced when RECHECK is non-nil." - (let* ((obj (assoc archive configuration-layer--elpa-archives-status)) - (state (cdr obj)) - (url (format "%sarchive-contents" (cdr (assoc archive package-archives))))) - (when (and (or (eq state 'unknown) recheck) - url) - (condition-case nil - (if (url-http-file-exists-p url) - (setq state 'available) - (setq state 'unavailable)) - ((error) (setq state 'unavailable))) - (setcdr (assoc archive configuration-layer--elpa-archives-status) state)) - (message "archive '%s' at %s is %s" archive url state) +Available return values are available and unavailable." + (let ((url (format "%sarchive-contents" + (cdr (assoc archive package-archives)))) + state) + (condition-case nil + (if (url-http-file-exists-p url) + (setq state 'available) + (setq state 'unavailable)) + ((error) (setq state 'unavailable))) state)) (defun configuration-layer//get-available-archive-url (archive) - (if (eq 'available (configuration-layer//check-archive-status archive t)) + (if (eq 'available (configuration-layer//check-archive-status archive)) (cdr (assoc archive package-archives)) - (let ((obj (assoc archive configuration-layer-fallback-package-archives))) - (when obj - (setcdr - (assoc archive package-archives) - (cdr (configuration-layer//resolve-package-archive obj))) - (setq configuration-layer-fallback-package-archives - (delq obj configuration-layer-fallback-package-archives)) - (configuration-layer//get-available-archive-url archive))))) + (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'. @@ -396,8 +375,10 @@ refreshed during the current session." (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 %s. +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 @@ -408,10 +389,16 @@ new third-party packages (e. g. by editing 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) - (cdr - (configuration-layer//resolve-package-archive - (assoc (car archive) configuration-layer--elpa-archives))))) + (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) From 595f5ab361be1e20c6544cc5b621d88441669a3c Mon Sep 17 00:00:00 2001 From: d12frosted Date: Fri, 16 Sep 2016 18:24:28 +0300 Subject: [PATCH 5/5] allow to use local package archive urls --- core/core-configuration-layer.el | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/core/core-configuration-layer.el b/core/core-configuration-layer.el index f223e5b00579..8c5bbfe85f3f 100644 --- a/core/core-configuration-layer.el +++ b/core/core-configuration-layer.el @@ -333,11 +333,12 @@ The returned list has a `package-archives' compliant format." Available return values are available and unavailable." (let ((url (format "%sarchive-contents" (cdr (assoc archive package-archives)))) - state) + (state 'unavailable)) (condition-case nil - (if (url-http-file-exists-p url) - (setq state 'available) - (setq state 'unavailable)) + (when (or (and (string-prefix-p "/" url) + (file-readable-p url)) + (url-http-file-exists-p url)) + (setq state 'available)) ((error) (setq state 'unavailable))) state))