improve error handling in case of unknown URI type

1 files changed, 39 insertions, 28 deletions

diff --git a/henrietta-cache.scm b/henrietta-cache.scm
index 346f6f7..3eea0ef 100644
--- a/henrietta-cache.scm
+++ b/henrietta-cache.scm
@@ -86,6 +86,8 @@ EOF
                 (and-let* ((uri-alias (car uri/releases))
                            (uri-info (alist-ref uri-alias uris))
                            (type (car uri-info))
+                           (downloader (or (alist-ref type dispatchers)
+                                           (error "Unknown URI type" type)))
                            (uri-template (cadr uri-info)))
                   (for-each
                    (lambda (egg-release)
@@ -108,13 +110,22 @@ EOF
                                (print-error-message exn (current-error-port))
                                (flush-output (current-error-port)))
                              (create-directory cache-dir #t)
-                             ((alist-ref type dispatchers eq? void) uri cache-dir))))))
+                             (downloader uri cache-dir))))))
                    (cdr uri/releases))))
               uris/releases)))
 
 (define (alist-add! key value alist)
   (alist-update! key (cons value (alist-ref key alist eq? '())) alist))
 
+(define (read-release-info-file uri egg-name)
+  (handle-exceptions exn
+    (begin
+      (fprintf (current-error-port)
+               "Could not fetch release-info file for egg ~A from ~A\n"
+               egg-name uri)
+      (flush-output (current-error-port)))
+    (with-input-from-request uri #f read-file)))
+
 (define (update-egg-cache)
   (for-each
    (lambda (egg)
@@ -126,33 +137,33 @@ EOF
        (printf "Caching egg '~A'\n" egg-name)
        (flush-output)
        (handle-exceptions exn
-         (begin
-           (fprintf (current-error-port)
-                    "Could not fetch release-info file for egg ~A from ~A\n"
-                    egg-name uri)
-           (flush-output (current-error-port)))
-        (let collect-releases ((info (with-input-from-request uri #f read-file))
-                               (uris/releases '())
-                               (uris '()))
-          (if (null? info)
-              (download-all-release-files egg-name uris/releases uris)
-              ;; There must be a simpler way to encode optional values
-              (match (car info)
-                (('uri type uri)        ; The "default" URI
-                 (collect-releases (cdr info) uris/releases
-                                   (alist-update! 'default (list type uri) uris)))
-                (('uri type uri alias)
-                 (collect-releases (cdr info) uris/releases
-                                   (alist-update! alias (list type uri) uris)))
-                (('release version)     ; For the "default" URI
-                 (collect-releases (cdr info)
-                                   (alist-add! 'default version uris/releases)
-                                   uris))
-                (('release version alias)
-                 (collect-releases (cdr info)
-                                   (alist-add! alias version uris/releases)
-                                   uris))
-                (else (collect-releases (cdr info) uris/releases uris))))))))
+         (begin (fprintf (current-error-port) "----\n")
+                (fprintf (current-error-port) "Error downloading egg ~A\n" egg-name)
+                (print-error-message exn (current-error-port))
+                (fprintf (current-error-port) "----\n")
+                (flush-output (current-error-port)))
+         (let collect-releases ((info (read-release-info-file uri egg-name))
+                                (uris/releases '())
+                                (uris '()))
+           (if (null? info)
+               (download-all-release-files egg-name uris/releases uris)
+               ;; There must be a simpler way to encode optional values
+               (match (car info)
+                 (('uri type uri)       ; The "default" URI
+                  (collect-releases (cdr info) uris/releases
+                                    (alist-update! 'default (list type uri) uris)))
+                 (('uri type uri alias)
+                  (collect-releases (cdr info) uris/releases
+                                    (alist-update! alias (list type uri) uris)))
+                 (('release version)    ; For the "default" URI
+                  (collect-releases (cdr info)
+                                    (alist-add! 'default version uris/releases)
+                                    uris))
+                 (('release version alias)
+                  (collect-releases (cdr info)
+                                    (alist-add! alias version uris/releases)
+                                    uris))
+                 (else (collect-releases (cdr info) uris/releases uris))))))))
    (let ((uri (uri-reference *egg-list*)))
      (if (absolute-uri? uri)            ; Assume this is a http reference then
          (call-with-input-request uri #f read-file)