From a312dbcab97d4717b45bf4a3f86954244b03048e Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Tue, 24 May 2011 21:38:19 +0200
Subject: Add better error reporting to make Felix happy :)

---
 henrietta-cache.scm | 87 ++++++++++++++++++++++++++++++++---------------------
 1 file changed, 53 insertions(+), 34 deletions(-)

(limited to 'henrietta-cache.scm')

diff --git a/henrietta-cache.scm b/henrietta-cache.scm
index c391964..d2b6728 100644
--- a/henrietta-cache.scm
+++ b/henrietta-cache.scm
@@ -42,10 +42,14 @@ EOF
       (error "Got an error while executing command " cmd))))
 
 (define (pipe-from-http uri cmd)
-  (call-with-input-request
-   uri #f (lambda (i) (call-with-output-pipe*
-                        cmd
-                        (lambda (o) (copy-port i o))))))
+  (condition-case
+      (call-with-input-request
+       uri #f (lambda (i) (call-with-output-pipe*
+                           cmd
+                           (lambda (o) (copy-port i o)))))
+    (e (exn http)
+       (error (sprintf "Could not download ~A -- ~A"
+                       uri (get-condition-property e 'exn 'message))))))
 
 (define (download-release distribution-file-type uri cache-dir)
   (case distribution-file-type
@@ -58,9 +62,13 @@ EOF
     ((zip)
      (let ((tmpdir (create-temporary-directory))
            (tmp-zipfile (create-temporary-file)))
-       (call-with-input-request
-        uri #f (lambda (i) (call-with-output-file tmp-zipfile
-                             (lambda (o) (copy-port i o)))))
+       (condition-case
+           (call-with-input-request
+            uri #f (lambda (i) (call-with-output-file tmp-zipfile
+                                 (lambda (o) (copy-port i o)))))
+         (e (exn http)
+            (error (sprintf "Could not fetch zip-file ~A -- ~A"
+                            uri (get-condition-property e 'exn 'message)))))
        (let* ((cmd (sprintf "unzip -d ~A -o -qq ~A"
                             (qs tmpdir) (qs tmp-zipfile)))
               (status (system cmd)))
@@ -77,31 +85,42 @@ EOF
          (rename-file contents-dir cache-dir)
          (system (sprintf "rm -rf ~A" (qs tmpdir))))))
     ((meta-file)
-     (let* ((meta (car (call-with-input-request uri #f read-file)))
-            (uri (uri-reference uri))
-            (add-to-uri
-             (lambda (f)
-               (let* ((components (string-split f "/"))
-                      (rel (update-uri (uri-reference "") path: components)))
-                 (uri-relative-to rel uri))))
-            (files (alist-ref 'files meta)))
-       (unless files
-         (error "No \"files\" entry found in meta file" uri))
-       (for-each
-        (lambda (file)
-          (printf "\t\t~A...\n" file)
-          (flush-output)
-          (and-let* ((dirname (pathname-directory file))
-                     (directory (make-pathname cache-dir dirname)))
-            (unless (file-exists? directory)
-              (create-directory directory #t)))
-          (call-with-input-request
-           (add-to-uri file) #f
-           (lambda (i)
-             (call-with-output-file
-                 (make-pathname cache-dir file)
-               (lambda (o) (copy-port i o))))))
-        files)))
+     (condition-case
+         (let* ((meta (car (call-with-input-request uri #f read-file)))
+                (uri (uri-reference uri))
+                (add-to-uri
+                 (lambda (f)
+                   (let* ((components (string-split f "/"))
+                          (rel (update-uri (uri-reference "") path: components)))
+                     (uri-relative-to rel uri))))
+                (files (alist-ref 'files meta)))
+           (unless files
+             (error "No \"files\" entry found in meta file" uri))
+           (for-each
+            (lambda (file)
+              (printf "\t\t~A...\n" file)
+              (flush-output)
+              (and-let* ((dirname (pathname-directory file))
+                         (directory (make-pathname cache-dir dirname)))
+                (unless (file-exists? directory)
+                  (create-directory directory #t)))
+              (condition-case
+                  (call-with-input-request
+                   (add-to-uri file) #f
+                   (lambda (i)
+                     (call-with-output-file
+                         (make-pathname cache-dir file)
+                       (lambda (o) (copy-port i o)))))
+                (e (exn http)
+                   (error (sprintf
+                           (conc "Could not download file \"~A\", "
+                                 "listed in meta-file (full URI: ~A) -- ~A")
+                           file (uri->string (add-to-uri file))
+                           (get-condition-property e 'exn 'message))))))
+            files))
+       (e (exn http)
+          (error (sprintf "Could not download meta-file \"~A\" -- ~A\n"
+                          uri (get-condition-property e 'exn 'message))))))
     (else (error "Unknown distribution file type" distribution-file-type))))
 
 (define (download-all-release-files egg-name uris/releases uris)
@@ -143,8 +162,8 @@ EOF
   (handle-exceptions exn
     (begin
       (fprintf (current-error-port)
-               "Could not fetch release-info file for egg ~A from ~A\n"
-               egg-name uri)
+               "Could not fetch release-info file for egg ~A from ~A -- ~A\n"
+               egg-name uri (get-condition-property exn 'exn 'message))
       (flush-output (current-error-port))
       '())
     (with-input-from-request uri #f read-file)))
-- 
cgit v1.2.3