summaryrefslogtreecommitdiff
path: root/henrietta-cache.scm
diff options
context:
space:
mode:
Diffstat (limited to 'henrietta-cache.scm')
-rw-r--r--henrietta-cache.scm67
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)