summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--henrietta-cache.scm83
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))))