diff options
| -rw-r--r-- | henrietta-cache.scm | 78 |
1 files changed, 46 insertions, 32 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index 97adffc..346f6f7 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -1,12 +1,13 @@ -(use utils posix http-client matchable) +(use utils posix http-client matchable uri-common) (define (usage code) (print #<#EOF usage: henrietta-cache [OPTION ...] -h -help show this message - -c -cache-dir CACHEDIR put the egg cache in this directory - -e -egg-list EGGLIST file containing the master list of available eggs + -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 Henrietta-cache will download cached copies of each egg listed in the file EGGLIST, to CACHEDIR. @@ -50,12 +51,12 @@ EOF `((targz . ,(lambda (uri cache-dir) (pipe-from-http uri - (sprintf "(cd ~A; gzcat | pax -r -s ',^[^/]*/,,')" + (sprintf "(cd ~A; gzcat | pax -r -s ',^[^/]*/*,,')" (qs cache-dir))))) (tarbz2 . ,(lambda (uri cache-dir) (pipe-from-http uri - (sprintf "(cd ~A; bzcat | pax -r -s ',^[^/]*/,,')" + (sprintf "(cd ~A; bzcat | pax -r -s ',^[^/]*/*,,')" (qs cache-dir))))) (zip . ,(lambda (uri cache-dir) (let ((tmpdir (create-temporary-directory)) @@ -97,12 +98,15 @@ EOF (uri (replace-uri-patterns uri-template patterns))) (printf "\tDownloading release ~A from ~A\n" egg-release uri) + (flush-output) (handle-exceptions exn (begin (system (sprintf "rm -rf ~A" cache-dir)) - (printf "Error downloading or extracting egg '~A' release ~A: " - egg-name egg-release) - (print-error-message exn)) + (fprintf (current-error-port) + "Error downloading or extracting egg '~A' release ~A: " + egg-name egg-release) + (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)))))) (cdr uri/releases)))) @@ -120,29 +124,39 @@ EOF (chicken-release . ,*chicken-release*))) (uri (replace-uri-patterns egg-uri-template patterns))) (printf "Caching egg '~A'\n" egg-name) - (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))))))) - (call-with-input-file *egg-list* read-file))) + (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)))))))) + (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) + (call-with-input-file *egg-list* read-file))))) (define *short-options* '(#\h #\c #\e)) @@ -161,7 +175,7 @@ EOF (loop (cddr args))) ((or (string=? arg "-e") (string=? arg "-egg-list")) (unless (pair? (cdr args)) (usage 1)) - (set! *egg-list* (string->symbol (cadr args))) + (set! *egg-list* (cadr args)) (loop (cddr args))) ((and (positive? (string-length arg)) (char=? #\- (string-ref arg 0))) |