diff options
Diffstat (limited to 'henrietta-cache.scm')
| -rw-r--r-- | henrietta-cache.scm | 83 |
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)))) |