[Chicken-hackers] [PATCH] handle "local" transport properly when downloading eggs

[Felix]

When trying all available sources for egg-download, do not invalidate
list-entries on failure for "local" transport.  This allows using
local egg-trees as "overlay" repositories. Hetwork-based transports
are still invalidated once a download failed, as it is assumed that
the network access is down (or timing out). This patch also fixes a
bug in the handling of "local" transport, which didn't test whether
the egg directory actually existed.


cheers
felix

>From e3e9eb2588476682eb00ee0bd449727b9a1ad3d3 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 26 Apr 2013 11:56:42 +0200
Subject: [PATCH] when trying all available sources for egg-download, do not
 invalidate list-entries on failure for "local" transport.
 This allows using local egg-trees as "overlay"
 repositories. Hetwork-based transports are still
 invalidated once a download failed, as it is assumed that
 the network access is down (or timing out). This patch also
 fixes a bug in the handling of "local" transport, which
 didn't test whether the egg directory acutally existed.

---
 chicken-install.scm |   45 +++++++++++++++++++++++----------------------
 setup-download.scm  |    4 +++-
 2 files changed, 26 insertions(+), 23 deletions(-)

diff --git a/chicken-install.scm b/chicken-install.scm
index 1ba5b97..4283d03 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -196,9 +196,6 @@
            (transport ,*default-transport*)))
         *default-sources* ) )
 
-  (define (invalidate-default-source! def)
-    (set! *default-sources* (delete def *default-sources* eq?)) )
-
   (define (deps key meta)
     (or (and-let* ((d (assq key meta)))
           (cdr d))
@@ -337,26 +334,30 @@
        (abort e) ] ) )
 
   (define (with-default-sources proc)
-    (let trying-sources ([defs (known-default-sources)])
-      (if (null? defs)
-          (proc #f #f
-                (lambda ()
-                  (with-output-to-port (current-error-port)
-                    (lambda ()
-                      (print "Could not determine a source of extensions. "
-                             "Please, specify a location and a transport for "
-                             "a source.")))
-                  (exit 1)))
-          (let* ([def (car defs)]
-                 [locn (resolve-location
-                       (cadr (or (assq 'location def)
-                                 (error "missing location entry" def))))]
-                 [trans (cadr (or (assq 'transport def)
-                                  (error "missing transport entry" def)))])
-           (proc trans locn
+    (let ((sources (known-default-sources)))
+      (let trying-sources ((defs sources))
+       (if (null? defs)
+           (proc #f #f
                  (lambda ()
-                    (invalidate-default-source! def)
-                    (trying-sources (cdr defs)) ) ) ) ) ) )
+                   (with-output-to-port (current-error-port)
+                     (lambda ()
+                       (print "Could not determine a source of extensions. "
+                              "Please specify a valid location and 
transport.")))
+                   (exit 1)))
+           (let ((def (car defs)))
+             (if def
+                 (let* ((locn (resolve-location
+                               (cadr (or (assq 'location def)
+                                         (error "missing location entry" 
def)))))
+                        (trans (cadr (or (assq 'transport def)
+                                         (error "missing transport entry" 
def)))))
+                   (proc trans locn
+                         (lambda ()
+                           (unless (eq? 'local trans)
+                             ;; invalidate this entry in the list of sources
+                             (set-car! defs #f))
+                           (trying-sources (cdr defs)))))
+                 (trying-sources (cdr defs))))))))
 
   (define (try-default-sources name version)
     (with-default-sources
diff --git a/setup-download.scm b/setup-download.scm
index 30934c4..06c040b 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -106,7 +106,9 @@
                           (if (and (file-exists? trunkdir) (directory? 
trunkdir))
                               (values trunkdir "trunk")
                               (values eggdir "") ) ) ) ) )
-       (cond (dest
+       (cond ((or (not (file-exists? eggdir)) (not (directory? eggdir)))
+              (values #f ""))
+             (dest
               (create-directory dest)
               (let ((qdest (qs (normalize-pathname dest)))
                     (qsrc (qs (normalize-pathname src)))
-- 
1.7.9.5