diff options
| author | Peter Bex <peter@more-magic.net> | 2012-01-31 20:04:40 +0100 |
|---|---|---|
| committer | Peter Bex <peter@more-magic.net> | 2012-01-31 20:04:40 +0100 |
| commit | d1fdca00933d07a81debf6631bb55a6074458222 (patch) | |
| tree | e23c6112f89847284160d2f58265b155a313da5c | |
| parent | 40dc846436e0251aeaff4570e68c5889ac6ea387 (diff) | |
| parent | f7608301daf1af4b39a11051829eabc6d5685df9 (diff) | |
| download | henrietta-cache-d1fdca00933d07a81debf6631bb55a6074458222.tar.gz | |
Merged in DerGuteMoritz/henrietta-cache (pull request #3)
| -rw-r--r-- | henrietta-cache.scm | 19 |
1 files changed, 14 insertions, 5 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index f7914fe..8f63bba 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -1,4 +1,4 @@ -(use utils posix http-client matchable uri-common srfi-1) +(use utils posix http-client matchable uri-common srfi-1 chicken-syntax) (define (usage code) (print #<#EOF @@ -8,6 +8,7 @@ usage: henrietta-cache [OPTION ...] -c -cache-dir CACHEDIR put egg cache in this dir, defaults to "cache" -e -egg-list EGGLIST file containing the master list of available eggs, defaults to "egg-locations". Can be an URI + -i -init-file INITFILE a file to load before starting the process Henrietta-cache will download cached copies of each egg listed in the file EGGLIST, to CACHEDIR. @@ -26,9 +27,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 +204,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 +219,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))) |