diff options
| -rw-r--r-- | henrietta-cache.scm | 67 |
1 files changed, 39 insertions, 28 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index 346f6f7..3eea0ef 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -86,6 +86,8 @@ EOF (and-let* ((uri-alias (car uri/releases)) (uri-info (alist-ref uri-alias uris)) (type (car uri-info)) + (downloader (or (alist-ref type dispatchers) + (error "Unknown URI type" type))) (uri-template (cadr uri-info))) (for-each (lambda (egg-release) @@ -108,13 +110,22 @@ EOF (print-error-message exn (current-error-port)) (flush-output (current-error-port))) (create-directory cache-dir #t) - ((alist-ref type dispatchers eq? void) uri cache-dir)))))) + (downloader uri cache-dir)))))) (cdr uri/releases)))) uris/releases))) (define (alist-add! key value alist) (alist-update! key (cons value (alist-ref key alist eq? '())) alist)) +(define (read-release-info-file uri egg-name) + (handle-exceptions exn + (begin + (fprintf (current-error-port) + "Could not fetch release-info file for egg ~A from ~A\n" + egg-name uri) + (flush-output (current-error-port))) + (with-input-from-request uri #f read-file))) + (define (update-egg-cache) (for-each (lambda (egg) @@ -126,33 +137,33 @@ EOF (printf "Caching egg '~A'\n" egg-name) (flush-output) (handle-exceptions exn - (begin - (fprintf (current-error-port) - "Could not fetch release-info file for egg ~A from ~A\n" - egg-name uri) - (flush-output (current-error-port))) - (let collect-releases ((info (with-input-from-request uri #f read-file)) - (uris/releases '()) - (uris '())) - (if (null? info) - (download-all-release-files egg-name uris/releases uris) - ;; There must be a simpler way to encode optional values - (match (car info) - (('uri type uri) ; The "default" URI - (collect-releases (cdr info) uris/releases - (alist-update! 'default (list type uri) uris))) - (('uri type uri alias) - (collect-releases (cdr info) uris/releases - (alist-update! alias (list type uri) uris))) - (('release version) ; For the "default" URI - (collect-releases (cdr info) - (alist-add! 'default version uris/releases) - uris)) - (('release version alias) - (collect-releases (cdr info) - (alist-add! alias version uris/releases) - uris)) - (else (collect-releases (cdr info) uris/releases uris)))))))) + (begin (fprintf (current-error-port) "----\n") + (fprintf (current-error-port) "Error downloading egg ~A\n" egg-name) + (print-error-message exn (current-error-port)) + (fprintf (current-error-port) "----\n") + (flush-output (current-error-port))) + (let collect-releases ((info (read-release-info-file uri egg-name)) + (uris/releases '()) + (uris '())) + (if (null? info) + (download-all-release-files egg-name uris/releases uris) + ;; There must be a simpler way to encode optional values + (match (car info) + (('uri type uri) ; The "default" URI + (collect-releases (cdr info) uris/releases + (alist-update! 'default (list type uri) uris))) + (('uri type uri alias) + (collect-releases (cdr info) uris/releases + (alist-update! alias (list type uri) uris))) + (('release version) ; For the "default" URI + (collect-releases (cdr info) + (alist-add! 'default version uris/releases) + uris)) + (('release version alias) + (collect-releases (cdr info) + (alist-add! alias version uris/releases) + uris)) + (else (collect-releases (cdr info) uris/releases uris)))))))) (let ((uri (uri-reference *egg-list*))) (if (absolute-uri? uri) ; Assume this is a http reference then (call-with-input-request uri #f read-file) |