diff options
| -rw-r--r-- | henrietta-cache.scm | 87 |
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))) |