Instead of trying to be fancy and "portable" with pax, just use tar.

Pax supports replacement patterns which makes it slightly simpler to
use (and it's actually a standard), we'll just rely on the commonly
supported tar flags "x" and "f", and just hope it'll work everywhere.
This is because (at least on NetBSD), pax only supports plain ustar
format, which has silly limitations on file name length.  Longer file
names are a GNU extension, which means we'll need something that
supports these extensions anyway.  On the long run we should probably
switch to libarchive, but I don't feel like writing yet another egg
just to work around these few problems.

Also, don't create the target directory in advance but let the
procedures do this, so if something breaks we won't get empty
directories. This ensures it will be retried later.

1 files changed, 48 insertions, 35 deletions

diff --git a/henrietta-cache.scm b/henrietta-cache.scm
index f12efa9..ce2ed93 100644
--- a/henrietta-cache.scm
+++ b/henrietta-cache.scm
@@ -85,6 +85,7 @@ EOF
            (let* ((components (string-split f "/"))
                   (rel (update-uri (uri-reference "") path: components)))
              (uri-relative-to rel base-uri)))))
+    (create-directory cache-dir #t)     ; TODO: Download to tmpdir, then move
     (for-each
      (lambda (file)
        (printf "\t\t~A...\n" file)
@@ -108,42 +109,55 @@ EOF
                     (get-condition-property e 'exn 'message))))))
      files)))
 
+;; Make-cmd is a lambda which accepts the temporary file- and dirname
+;; and returns a suitable command to execute using SYSTEM
+(define (download-and-extract type uri cache-dir make-cmd)
+  (let ((tmp-dir (create-temporary-directory))
+        (tmp-file (create-temporary-file)))
+    (handle-exceptions exn
+        (begin
+          (delete-file tmp-file)
+          (system (sprintf "rm -rf ~A" (qs tmp-dir)))
+          (signal exn))
+      (condition-case
+          (call-with-input-request
+           uri #f (lambda (i) (call-with-output-file tmp-file
+                                (lambda (o) (copy-port i o)))))
+        (e (exn http)
+           (error (sprintf "Could not fetch ~A-file ~A -- ~A"
+                    type uri (get-condition-property e 'exn 'message)))))
+      (let* ((cmd (make-cmd tmp-file tmp-dir))
+             (status (system cmd)))
+        (unless (zero? status)
+          (error "Got an error executing command" cmd)))
+      (create-directory cache-dir #t)
+      ;; Some people extract to the current directory, some include the
+      ;; directory
+      (let* ((contents (directory tmp-dir))
+             (contents-dir (if (= 1 (length contents))
+                               (make-pathname tmp-dir (car contents))
+                               tmp-dir))
+             (cmd (sprintf "mv ~A/* ~A" (qs contents-dir) (qs cache-dir)))
+             (status (system cmd)))
+        (unless (zero? status)
+          (error "Got an error executing command" cmd))
+        (delete-file tmp-file)
+        (system (sprintf "rm -rf ~A" (qs tmp-dir)))))))
+
 (define (download-release distribution-file-type uri cache-dir)
   (case distribution-file-type
-    ((targz)
-     (pipe-from-http
-      uri (sprintf "(cd ~A; zcat | pax -r -s ',^[^/]*/*,,')" (qs cache-dir))))
-    ((tarbz2)
-     (pipe-from-http
-      uri (sprintf "(cd ~A; bzcat | pax -r -s ',^[^/]*/*,,')" (qs cache-dir))))
-    ((zip)
-     (let ((tmpdir (create-temporary-directory))
-           (tmp-zipfile (create-temporary-file)))
-       (condition-case
-           (call-with-input-request
-            uri #f (lambda (i) (call-with-output-file tmp-zipfile
-                                 (lambda (o) (copy-port i o)))))
-         (e (exn http)
-            (error (sprintf "Could not fetch zip-file ~A -- ~A"
-                            uri (get-condition-property e 'exn 'message)))))
-       (let* ((cmd (sprintf "unzip -d ~A -o -qq ~A"
-                            (qs tmpdir) (qs tmp-zipfile)))
-              (status (system cmd)))
-         (delete-file tmp-zipfile)
-         (unless (zero? status)
-           (system (sprintf "rm -rf ~A" (qs tmpdir)))
-           (error "Got an error executing command" cmd)))
-       ;; Some people unzip to the current directory, some include the
-       ;; directory
-       (let* ((contents (directory tmpdir))
-              (contents-dir (if (= 1 (length contents))
-                                (make-pathname tmpdir (car contents))
-                                tmpdir))
-              (cmd (sprintf "mv ~A/* ~A" (qs contents-dir) (qs cache-dir)))
-              (status (system cmd)))
-         (system (sprintf "rm -rf ~A" (qs tmpdir)))
-         (unless (zero? status)
-           (error "Got an error executing command" cmd)))))
+    ((targz tarbz2 zip)
+     (download-and-extract
+      distribution-file-type uri cache-dir
+      (lambda (archive dir)
+        ;; Instead of messing about with tar, zcat, bzcat, unzip etc,
+        ;; we should use libarchive.
+        (case distribution-file-type
+          ((targz) (sprintf "(cd ~A && zcat ~A | tar xf -)" (qs dir) (qs archive)))
+          ((tarbz2) (sprintf "(cd ~A && bzcat ~A | tar xf -)" (qs dir) (qs archive)))
+          ((zip) (sprintf "unzip -d ~A -o -qq ~A" (qs dir) (qs archive)))
+          (else (error (sprintf "Unknown archive type `~S' (shouldn't happen!)"
+                         distribution-file-type)))))))
     ((meta-file)
      (condition-case
          (let* ((meta (car (call-with-input-request uri #f read-file)))
@@ -208,7 +222,6 @@ EOF
                                          egg-name
                                          egg-release
                                          (get-condition-property exn 'exn 'message)))
-                             (create-directory cache-dir #t)
                              (download-release type uri cache-dir)
                              (run-hook 'download-release-success egg-name egg-release))))))
                    (cdr uri/releases))))