core: add support for local elpa repositories

It is now possible to add local elpa repositories to private variable
configuration-layer--elpa-archives for instance:

(defvar configuration-layer--elpa-archives
  '(("spacelpa" . "~/.emacs.d/.cache/spacelpa/"))
  "List of ELPA archives required by Spacemacs.")

New functions:
- configuration-layer//package-archive-absolute-pathp
- configuration-layer//package-archive-local-pathp

core/core-configuration-layer.el

@@ -307,6 +307,20 @@ cache folder.")
   (configuration-layer/load-or-install-protected-package 'package-build)
   (configuration-layer/load-or-install-protected-package 'quelpa))
 
+(defun configuration-layer//package-archive-absolute-pathp (archive)
+  "Return t if ARCHIVE has an absolute path defined."
+  (let ((path (cdr archive)))
+    (or (string-match-p "http" path)
+        (string-prefix-p "~" path)
+        (string-prefix-p "/" path))))
+
+(defun configuration-layer//package-archive-local-pathp (archive)
+  "Return t if ARCHIVE has a local path."
+  (let ((path (cdr archive)))
+    (or (string-prefix-p "~" path)
+        (string-prefix-p "/" path)
+        (string-prefix-p "\." path))))
+
 (defun configuration-layer//resolve-package-archives (archives)
   "Resolve HTTP handlers for each archive in ARCHIVES and return a list
 of all reachable ones.
@@ -315,23 +329,23 @@ left untouched.
 The returned list has a `package-archives' compliant format."
   (mapcar
    (lambda (x)
-     (cons (car x)
+     (let ((aname (car x))
-           (if (or (string-match-p "http" (cdr x))
+           (apath (cdr x)))
-                   (string-prefix-p "~" (cdr x))
+       (cons aname
-                   (string-prefix-p "/" (cdr x)))
+             (if (configuration-layer//package-archive-absolute-pathp x)
-               (cdr x)
+                 apath
-             (concat
+               (concat
-              (if (and dotspacemacs-elpa-https
+                (if (and dotspacemacs-elpa-https
-                       (not spacemacs-insecure)
+                         (not spacemacs-insecure)
-                       ;; for now org ELPA repository does
+                         ;; for now org ELPA repository does
-                       ;; not support HTTPS
+                         ;; not support HTTPS
-                       ;; TODO when org ELPA repo support
+                         ;; TODO when org ELPA repo support
-                       ;; HTTPS remove the check
+                         ;; HTTPS remove the check
-                       ;; `(not (equal "org" (car x)))'
+                         ;; `(not (equal "org" aname))'
-                       (not (equal "org" (car x))))
+                         (not (equal "org" aname)))
-                  "https://"
+                    "https://"
-                "http://")
+                  "http://")
-              (cdr x)))))
+                apath)))))
    archives))
 
 (defun configuration-layer/retrieve-package-archives (&optional quiet force)
@@ -355,32 +369,38 @@ refreshed during the current session."
     (let ((count (length package-archives))
           (i 1))
       (dolist (archive package-archives)
-        (unless quiet
+        (let ((aname (car archive))
-          (spacemacs-buffer/replace-last-line
+              (apath (cdr archive)))
-           (format "--> refreshing package archive: %s... [%s/%s]"
+          (unless quiet
-                   (car archive) i count) t))
+            (spacemacs-buffer/replace-last-line
-        (spacemacs//redisplay)
+             (format "--> refreshing package archive: %s... [%s/%s]"
-        (setq i (1+ i))
+                     aname i count) t))
-        (unless (eq 'error
+          (spacemacs//redisplay)
-                    (with-timeout
+          (setq i (1+ i))
-                        (dotspacemacs-elpa-timeout
+          (unless
-                         (progn
+              (and (not (configuration-layer//package-archive-local-pathp
-                           (display-warning
+                         archive))
-                            'spacemacs
+                   (eq 'error
-                            (format
+                       (with-timeout
-                             "\nError connection time out for %s repository!"
+                           (dotspacemacs-elpa-timeout
-                             (car archive)) :warning)
+                            (progn
-                           'error))
+                              (display-warning
-                      (condition-case err
+                               'spacemacs
-                          (url-retrieve-synchronously (cdr archive))
+                               (format
-                        ('error
+                                "\nError connection time out for %s repository!"
-                         (display-warning 'spacemacs
+                                aname) :warning)
-                          (format
+                              'error))
-                           "\nError while contacting %s repository!"
+                         (condition-case err
-                           (car archive)) :warning)
+                             (url-retrieve-synchronously apath)
-                         'error))))
+                           ('error
-          (let ((package-archives (list archive)))
+                            (display-warning
-            (package-refresh-contents))))
+                             'spacemacs
+                             (format
+                              "\nError while contacting %s repository!"
+                              aname) :warning)
+                            'error)))))
+            (let ((package-archives (list archive)))
+              (package-refresh-contents)))))
       (package-read-all-archive-contents)
       (unless quiet (spacemacs-buffer/append "\n")))))
 

tests/core/core-configuration-layer-utest.el

@@ -217,6 +217,62 @@
     (helper--set-layers `(,(cfgl-layer "layer2" :name 'layer2)) t)
     (should (eq 'layer2 (cfgl-package-get-safe-owner pkg)))))
 
+;; ---------------------------------------------------------------------------
+;; configuration-layer//package-archive-absolute-pathp
+;; ---------------------------------------------------------------------------
+
+(ert-deftest test-package-archive-absolute-pathp--http-absolute-path ()
+  (let ((input '("melpa" . "http://melpa.org/packages/")))
+    (should (configuration-layer//package-archive-absolute-pathp input))))
+
+(ert-deftest test-package-archive-absolute-pathp--https-absolute-path ()
+  (let ((input '("melpa" . "https://melpa.org/packages/")))
+    (should (configuration-layer//package-archive-absolute-pathp input))))
+
+(ert-deftest test-package-archive-absolute-pathp--user-home-tilde-absolute-path ()
+  (let ((input '("spacelpa" . "~/.elpa/spacelpa")))
+    (should (configuration-layer//package-archive-absolute-pathp input))))
+
+(ert-deftest test-package-archive-absolute-pathp--user-home-slash-absolute-path ()
+  (let ((input '("spacelpa" . "/home/rms/.elpa/spacelpa")))
+    (should (configuration-layer//package-archive-absolute-pathp input))))
+
+(ert-deftest test-package-archive-absolute-pathp--relative-path-local ()
+  (let ((input '("melpa" . "../.elpa/spacelpa")))
+    (should (not (configuration-layer//package-archive-absolute-pathp input)))))
+
+(ert-deftest test-package-archive-absolute-pathp--not-absolute-path-remote ()
+  (let ((input '("melpa" . "melpa.org/spacelpa")))
+    (should (not (configuration-layer//package-archive-absolute-pathp input)))))
+
+;; ---------------------------------------------------------------------------
+;; configuration-layer//package-archive-local-pathp
+;; ---------------------------------------------------------------------------
+
+(ert-deftest test-package-archive-local-pathp--http-not-local-path ()
+  (let ((input '("melpa" . "http://melpa.org/packages/")))
+    (should (not (configuration-layer//package-archive-local-pathp input)))))
+
+(ert-deftest test-package-archive-local-pathp--https-not-local-path ()
+  (let ((input '("melpa" . "https://melpa.org/packages/")))
+    (should (not (configuration-layer//package-archive-local-pathp input)))))
+
+(ert-deftest test-package-archive-local-pathp--user-home-tilde-local-path ()
+  (let ((input '("spacelpa" . "~/.elpa/spacelpa")))
+    (should (configuration-layer//package-archive-local-pathp input))))
+
+(ert-deftest test-package-archive-local-pathp--user-home-slash-local-path ()
+  (let ((input '("spacelpa" . "/home/rms/.elpa/spacelpa")))
+    (should (configuration-layer//package-archive-local-pathp input))))
+
+(ert-deftest test-package-archive-local-pathp--relative-local-path-local ()
+  (let ((input '("melpa" . "../.elpa/spacelpa")))
+    (should (configuration-layer//package-archive-local-pathp input))))
+
+(ert-deftest test-package-archive-local-pathp--default-not-local-path-remote ()
+  (let ((input '("melpa" . "melpa.org/spacelpa")))
+    (should (not (configuration-layer//package-archive-local-pathp input)))))
+
 ;; ---------------------------------------------------------------------------
 ;; configuration-layer//resolve-package-archives
 ;; ---------------------------------------------------------------------------