summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2011-03-20 17:30:31 +0100
committerPeter Bex <peter@more-magic.net>2011-03-20 17:30:31 +0100
commitdacca8fd6f9671f1e948616b6dede6d1213cefaf (patch)
treedd2c304e9886b4d9bdff3094fb16e22b32ad8018
parentfb0adb030bf3495669749180ba1e41216bab5c2a (diff)
downloadhenrietta-cache-dacca8fd6f9671f1e948616b6dede6d1213cefaf.tar.gz
improve error handling by logging errors to standard error and status output to standard output. Fix pax call to strip top-level directory correctly. Fix usage output
-rw-r--r--henrietta-cache.scm78
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)))