diff options
| -rw-r--r-- | henrietta-cache.scm | 16 |
1 files changed, 12 insertions, 4 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index f7914fe..ff132b0 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -26,9 +26,13 @@ EOF (define download-release-error-hook (make-parameter #f)) +(define read-release-info-file-error-hook + (make-parameter #f)) + (define hooks `((download-release-success . ,download-release-success-hook) - (download-release-error . ,download-release-error-hook))) + (download-release-error . ,download-release-error-hook) + (read-release-info-file-error . ,read-release-info-file-error-hook))) (define (run-hook hook-name . args) (and-let* ((hook (or (alist-ref hook-name hooks) @@ -199,7 +203,10 @@ EOF egg-name egg-release) (print-error-message exn (current-error-port)) (flush-output (current-error-port)) - (run-hook 'download-release-error egg-name egg-release)) + (run-hook 'download-release-error + egg-name + egg-release + (get-condition-property exn 'exn 'message))) (create-directory cache-dir #t) (download-release type uri cache-dir) (run-hook 'download-release-success egg-name egg-release)))))) @@ -211,10 +218,11 @@ EOF (define (read-release-info-file uri egg-name) (handle-exceptions exn - (begin + (let ((message (get-condition-property exn 'exn 'message))) (fprintf (current-error-port) "Could not fetch release-info file for egg ~A from ~A -- ~A\n" - egg-name uri (get-condition-property exn 'exn 'message)) + egg-name uri message) + (run-hook 'read-release-info-file-error egg-name uri message) (flush-output (current-error-port)) '()) (with-input-from-request uri #f read-file))) |