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

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)))