summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2011-05-24 21:38:19 +0200
committerPeter Bex <peter@more-magic.net>2011-05-24 21:38:19 +0200
commita312dbcab97d4717b45bf4a3f86954244b03048e (patch)
treed5776224e202280c44933b506e1af0b8ea203e46
parentc1a74a68d2ef96ec9e0d455a16a7ee6ee7b12167 (diff)
downloadhenrietta-cache-a312dbcab97d4717b45bf4a3f86954244b03048e.tar.gz
Add better error reporting to make Felix happy :)
-rw-r--r--henrietta-cache.scm87
1 files changed, 53 insertions, 34 deletions
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)))