TakeV
/
spacemacs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: use request.el to check elpa archive availability 

Add request.el to core/libs
Refactor package.el initialization in configuration-layer.el
Cosmetic improvements to loading messages
Remove redefinition of package-refresh-packages
This commit is contained in:
syl20bnr 2015-12-02 23:25:00 -05:00
parent 7be61762ed
commit d822241739
7 changed files with 1471 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
core/core-configuration-layer.el
View File

@ -19,36 +19,13 @@
(require 'package)
(require 'warnings)
(require 'ht)
(require 'request)
(require 'core-dotspacemacs)
(require 'core-funcs)
(require 'core-spacemacs-buffer)
(unless package--initialized
(let ((archives '(("melpa" . "melpa.org/packages/")
("org" . "orgmode.org/elpa/")
("gnu" . "elpa.gnu.org/packages/"))))
(setq package-archives
(mapcar (lambda (x)
(cons (car x) (concat
(if (and dotspacemacs-elpa-https
;; 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)))
;; optimization, no need to activate all the packages so early
(setq package-enable-at-startup nil)
(package-initialize 'noactivate)
;; Emacs 24.3 and above ships with python.el but in some Emacs 24.3.1 packages
;; for Ubuntu, python.el seems to be missing.
;; This hack adds marmalade repository for this case only.
(unless (or (package-installed-p 'python) (version< emacs-version "24.3"))
(add-to-list 'package-archives
'("marmalade" . "https://marmalade-repo.org/packages/"))))
(defconst configuration-layer--refresh-package-timeout 3
"Timeout in seconds to reach a package archive page.")
(defconst configuration-layer-template-directory
(expand-file-name (concat spacemacs-core-directory "templates/"))
@ -135,6 +112,12 @@
:documentation
"If non-nil this package is excluded from all layers.")))
(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--layers '()
"A non-sorted list of `cfgl-layer' objects.")
@ -162,6 +145,73 @@ the path for this layer.")
"List of strings corresponding to category names. A category is a
directory with a name starting with `+'.")
(defun configuration-layer/initialize ()
"Initialize `package.el'."
(unless package--initialized
(setq package-archives (configuration-layer//resolve-package-archives
configuration-layer--elpa-archives))
;; optimization, no need to activate all the packages so early
(setq package-enable-at-startup nil)
(package-initialize 'noactivate)
;; TODO remove the following hack when 24.3 support ends
;; Emacs 24.3 and above ships with python.el but in some Emacs 24.3.1
;; packages for Ubuntu, python.el seems to be missing.
;; This hack adds marmalade repository for this case only.
(unless (or (package-installed-p 'python) (version< emacs-version "24.3"))
(add-to-list 'package-archives
'("marmalade" . "https://marmalade-repo.org/packages/")))))
(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 (string-match-p "http" (cdr x))
(cdr x)
(concat (if (and dotspacemacs-elpa-https
;; 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))
(defun configuration-layer//retrieve-package-archives ()
"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."
(let ((count (length package-archives))
(i 1))
(dolist (archive package-archives)
(spacemacs-buffer/replace-last-line
(format "--> refreshing package archive: %s... [%s/%s]"
(car archive) i count) t)
(spacemacs//redisplay)
(setq i (1+ i))
(request (cdr archive) :sync t :type "GET"
:timeout configuration-layer--refresh-package-timeout
:error (function* (lambda (&key error-thrown &allow-other-keys)
(configuration-layer//set-error)
(spacemacs-buffer/append
(format "\n%s: %s"
(car error-thrown)
(cdr error-thrown)))))
:status-code '((200 . (lambda (&rest _)
(let ((package-archives (list archive)))
(package-refresh-contents)))))))
(package-read-all-archive-contents)
(spacemacs-buffer/append "\n")))
(defun configuration-layer/sync ()
"Synchronize declared layers in dotfile with spacemacs."
(dotspacemacs|call-func dotspacemacs/layers "Calling dotfile layers...")
@ -555,7 +605,7 @@ path."
('error
(configuration-layer//set-error)
(spacemacs-buffer/append
(format (concat "An error occurred while setting layer "
(format (concat "\nAn error occurred while setting layer "
"variable %s "
"(error: %s). Be sure to quote the value "
"if needed.\n") var err))))
@ -634,10 +684,7 @@ path."
(spacemacs-buffer/append
(format "Found %s new package(s) to install...\n"
noinst-count))
(spacemacs-buffer/append
"--> fetching new package repository indexes...\n")
(spacemacs//redisplay)
(package-refresh-contents)
(configuration-layer//retrieve-package-archives)
(setq installed-count 0)
(dolist (pkg-name noinst-pkg-names)
(setq installed-count (1+ installed-count))
@ -645,9 +692,10 @@ path."
(layer (when pkg (oref pkg :owner)))
(location (when pkg (oref pkg :location))))
(spacemacs-buffer/replace-last-line
(format "--> installing %s%s... [%s/%s]"
(if layer (format "%S:" layer) "dependency ")
pkg-name installed-count noinst-count) t)
(format "--> installing %s: %s%s... [%s/%s]"
(if layer "package" "dependency")
pkg-name (if layer (format "@%S" layer) "")
installed-count noinst-count) t)
(unless (package-installed-p pkg-name)
(condition-case err
(cond
@ -660,7 +708,7 @@ path."
('error
(configuration-layer//set-error)
(spacemacs-buffer/append
(format (concat "An error occurred while installing %s "
(format (concat "\nAn error occurred while installing %s "
"(error: %s)\n") pkg-name err))))))
(spacemacs//redisplay))
(spacemacs-buffer/append "\n"))))
@ -828,7 +876,7 @@ path."
(configuration-layer//set-error)
(spacemacs-buffer/append
(format
(concat "An error occurred while pre-configuring %S "
(concat "\nAn error occurred while pre-configuring %S "
"in layer %S (error: %s)\n")
pkg-name layer err))))))
(oref pkg :pre-layers))
@ -848,7 +896,7 @@ path."
(configuration-layer//set-error)
(spacemacs-buffer/append
(format
(concat "An error occurred while post-configuring %S "
(concat "\nAn error occurred while post-configuring %S "
"in layer %S (error: %s)\n")
pkg-name layer err))))))
(oref pkg :post-layers))))
@ -875,12 +923,9 @@ path."
If called with a prefix argument ALWAYS-UPDATE, assume yes to update."
(interactive "P")
(spacemacs-buffer/insert-page-break)
(spacemacs-buffer/append
"\nUpdating Emacs packages from remote repositories (ELPA, MELPA, etc.)... \n")
(spacemacs-buffer/append
"--> fetching new package repository indexes...\n")
(spacemacs//redisplay)
(package-refresh-contents)
(spacemacs-buffer/append (concat "\nUpdating Emacs packages from remote "
"repositories (ELPA, MELPA, etc.)...\n"))
(configuration-layer//retrieve-package-archives)
(setq configuration-layer--skipped-packages nil)
(let* ((update-packages
(configuration-layer//get-packages-to-update

60
core/core-emacs-ext.el
View File

@ -1,60 +0,0 @@
;;; core-emacs-ext.el --- Spacemacs Core File
;;
;; Copyright (c) 2012-2014 Sylvain Benner
;; Copyright (c) 2014-2015 Sylvain Benner & Contributors
;;
;; Author: Sylvain Benner <sylvain.benner@gmail.com>
;; URL: https://github.com/syl20bnr/spacemacs
;;
;; This file is not part of GNU Emacs.
;;
;;; License: GPLv3
(require 'core-spacemacs-buffer)
;; Disclaimer:
;; The code in this file is not meant to stay for ever, they are
;; temporary fixes that we should remove as soon as a better
;; solution is found.
;; TODO remove this code as soon as we have a clean alternative.
;; A good proposal is available here:
;; https://github.com/syl20bnr/spacemacs/commit/4d87ea626dafc066d911c83538e260dd2bef762f#commitcomment-14708731
(when (and (version<= "24.3.1" emacs-version)
(version<= emacs-version "24.5.1"))
;; for some reason with-eval-after-load does not work here in 24.3
;; maybe the backport is incorrect!
(eval-after-load 'package
'(progn
(defun package-refresh-contents ()
"Download the ELPA archive description if needed.
This informs Emacs about the latest versions of all packages, and
makes them available for download.
This redefinition adds a timeout of 5 seconds to contact each archive."
(interactive)
;; the first part is not available before Emacs 24.4 so we just ignore
;; it to be safe.
(unless (version< emacs-version "24.4")
;; FIXME: Do it asynchronously.
(unless (file-exists-p package-user-dir)
(make-directory package-user-dir t))
(let ((default-keyring (expand-file-name "package-keyring.gpg"
data-directory)))
(when (and package-check-signature (file-exists-p default-keyring))
(condition-case-unless-debug error
(progn
(epg-check-configuration (epg-configuration))
(package-import-keyring default-keyring))
(error (message "Cannot import default keyring: %S" (cdr error)))))))
(dolist (archive package-archives)
(condition-case-unless-debug nil
;; add timeout here
(with-timeout (5 (spacemacs-buffer/warning
"Cannot contact archive %s (reason: timeout)"
(cdr archive)))
(package--download-one-archive archive "archive-contents"))
(error (message "Failed to download `%s' archive."
(car archive)))))
(package-read-all-archive-contents)))))
(provide 'core-emacs-ext)

4
core/core-keybindings.el
View File

@ -11,10 +11,6 @@
;;; License: GPLv3
(require 'core-funcs)
(unless (require 'which-key nil t)
(spacemacs/load-or-install-protected-package 'which-key t))
(unless (require 'bind-map nil t)
(spacemacs/load-or-install-protected-package 'bind-map t))
(defvar spacemacs/prefix-titles nil
"alist for mapping command prefixes to long names.")

7
core/core-spacemacs.el
View File

@ -25,7 +25,6 @@
(require 'core-toggle)
(require 'core-micro-state)
(require 'core-use-package-ext)
(require 'core-emacs-ext)
(defgroup spacemacs nil
"Spacemacs customizations."
@ -81,7 +80,6 @@ initialization."
(dotspacemacs|call-func dotspacemacs/init "Calling dotfile init...")
(dotspacemacs|call-func dotspacemacs/user-init "Calling dotfile user init...")
;; spacemacs init
(require 'core-configuration-layer)
(switch-to-buffer (get-buffer-create spacemacs-buffer-name))
(setq initial-buffer-choice (lambda () (get-buffer spacemacs-buffer-name)))
(spacemacs-buffer/set-mode-line "")
@ -89,6 +87,9 @@ initialization."
(setq inhibit-startup-screen t)
;; silence ad-handle-definition about advised functions getting redefined
(setq ad-redefinition-action 'accept)
;; initialize the configuration layer system
(require 'core-configuration-layer)
(configuration-layer/initialize)
;; default theme
(let ((default-theme (car dotspacemacs-themes)))
(spacemacs/load-theme default-theme)
@ -127,9 +128,9 @@ initialization."
;; dash is required to prevent a package.el bug with f on 24.3.1
(spacemacs/load-or-install-protected-package 'dash t)
(spacemacs/load-or-install-protected-package 's t)
(spacemacs/load-or-install-protected-package 'bind-map t)
;; bind-key is required by use-package
(spacemacs/load-or-install-protected-package 'bind-key t)
(spacemacs/load-or-install-protected-package 'bind-map t)
(spacemacs/load-or-install-protected-package 'use-package t)
(setq use-package-verbose init-file-debug)
;; package-build is required by quelpa

70
core/libs/request-deferred.el Normal file
View File

@ -0,0 +1,70 @@
;;; request-deferred.el --- Wrap request.el by deferred
;; Copyright (C) 2012 Takafumi Arakaki
;; Author: Takafumi Arakaki <aka.tkf at gmail.com>
;; Package-Requires: ((deferred "0.3.1") (request "0.2.0"))
;; Version: 0.2.0
;; This file is NOT part of GNU Emacs.
;; request-deferred.el 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 of the License, or
;; (at your option) any later version.
;; request-deferred.el 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.
;; You should have received a copy of the GNU General Public License
;; along with request-deferred.el.
;; If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;;; Code:
(require 'request)
(require 'deferred)
(defun request-deferred (url &rest args)
"Send a request and return deferred object associated with it.
Following deferred callback takes a response object regardless of
the response result. To make sure no error occurs during the
request, check `request-response-error-thrown'.
Arguments are the same as `request', but COMPLETE callback cannot
be used as it is used for starting deferred callback chain.
Example::
(require 'request-deferred)
(deferred:$
(request-deferred \"http://httpbin.org/get\" :parser 'json-read)
(deferred:nextc it
(lambda (response)
(message \"Got: %S\" (request-response-data response)))))
"
(let* ((d (deferred:new #'identity))
(callback-post (apply-partially
(lambda (d &rest args)
(deferred:callback-post
d (plist-get args :response)))
d)))
;; As `deferred:errorback-post' requires an error object to be
;; posted, use `deferred:callback-post' for success and error
;; cases.
(setq args (plist-put args :complete callback-post))
(apply #'request url args)
d))
(provide 'request-deferred)
;;; request-deferred.el ends here

1269
core/libs/request.el Normal file
View File

File diff suppressed because it is too large Load Diff

40
tests/core/core-configuration-layer-utest.el
View File

@ -12,6 +12,46 @@
(require 'mocker)
(require 'core-configuration-layer)
;; ---------------------------------------------------------------------------
;; configuration-layer//resolve-package-archives
;; ---------------------------------------------------------------------------
(ert-deftest test-resolve-package-archives--simple-https ()
(let ((input '(("melpa" . "melpa.org/packages/")))
(dotspacemacs-elpa-https t))
(should (equal '(("melpa" . "https://melpa.org/packages/"))
(configuration-layer//resolve-package-archives input)))))
(ert-deftest test-resolve-package-archives--simple-http ()
(let ((input '(("melpa" . "melpa.org/packages/")))
dotspacemacs-elpa-https)
(should (equal '(("melpa" . "http://melpa.org/packages/"))
(configuration-layer//resolve-package-archives input)))))
(ert-deftest test-resolve-package-archives--org-supports-http ()
(let ((input '(("org" . "orgmode.org/elpa/")))
dotspacemacs-elpa-https)
(should (equal '(("org" . "http://orgmode.org/elpa/"))
(configuration-layer//resolve-package-archives input)))))
(ert-deftest test-resolve-package-archives--org-does-not-support-https ()
(let ((input '(("org" . "orgmode.org/elpa/")))
(dotspacemacs-elpa-https t))
(should (equal '(("org" . "http://orgmode.org/elpa/"))
(configuration-layer//resolve-package-archives input)))))
(ert-deftest test-resolve-package-archives--idempotent-when-already-http-prefix ()
(let ((input '(("melpa" . "http://melpa.org/packages/")))
(dotspacemacs-elpa-https t))
(should (equal '(("melpa" . "http://melpa.org/packages/"))
(configuration-layer//resolve-package-archives input)))))
(ert-deftest test-resolve-package-archives--idempotent-when-already-https-prefix ()
(let ((input '(("melpa" . "https://melpa.org/packages/")))
dotspacemacs-elpa-https)
(should (equal '(("melpa" . "https://melpa.org/packages/"))
(configuration-layer//resolve-package-archives input)))))
;; ---------------------------------------------------------------------------
;; configuration-layer//make-layers
;; ---------------------------------------------------------------------------