diff options
Diffstat (limited to 'henrietta-cache.scm')
| -rw-r--r-- | henrietta-cache.scm | 118 |
1 files changed, 57 insertions, 61 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index affbb02..fb631ae 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -47,64 +47,62 @@ EOF cmd (lambda (o) (copy-port i o)))))) -(define dispatchers - `((targz . ,(lambda (uri cache-dir) - (pipe-from-http - uri - (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 ',^[^/]*/*,,')" - (qs cache-dir))))) - (zip . ,(lambda (uri cache-dir) - (let ((tmpdir (create-temporary-directory)) - (tmp-zipfile (create-temporary-file))) - (call-with-input-request - uri #f (lambda (i) (call-with-output-file - tmp-zipfile - (lambda (o) (copy-port i o))))) - (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))) - (rename-file contents-dir cache-dir) - (system (sprintf "rm -rf ~A" (qs tmpdir))))))) - (meta-file . ,(lambda (uri cache-dir) - (let* ((meta (car (call-with-input-request uri #f read-file))) - (uri (uri-reference uri)) - (add-to-uri - (lambda (f) - (let ((rel (update-uri (uri-reference "") - path: (string-split f "/")))) - (uri-relative-to rel uri)))) - (files (alist-ref 'files meta))) - (unless files - (error "No \"files\" entry found in meta file" uri)) - (for-each - (lambda (file) - (printf "\t\t~A...\n" file) - (flush-output) - (and-let* ((dirname (pathname-directory file)) - (directory (make-pathname cache-dir dirname))) - (unless (file-exists? directory) - (create-directory directory #t))) - (call-with-input-request - (add-to-uri file) #f - (lambda (i) - (call-with-output-file - (make-pathname cache-dir file) - (lambda (o) (copy-port i o)))))) - files)))))) +(define (download-release distribution-file-type uri cache-dir) + (case distribution-file-type + ((targz) + (pipe-from-http + uri (sprintf "(cd ~A; gzcat | 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))) + (call-with-input-request + uri #f (lambda (i) (call-with-output-file tmp-zipfile + (lambda (o) (copy-port i o))))) + (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))) + (rename-file contents-dir cache-dir) + (system (sprintf "rm -rf ~A" (qs tmpdir)))))) + ((meta-file) + (let* ((meta (car (call-with-input-request uri #f read-file))) + (uri (uri-reference uri)) + (add-to-uri + (lambda (f) + (let* ((components (string-split f "/")) + (rel (update-uri (uri-reference "") path: components))) + (uri-relative-to rel uri)))) + (files (alist-ref 'files meta))) + (unless files + (error "No \"files\" entry found in meta file" uri)) + (for-each + (lambda (file) + (printf "\t\t~A...\n" file) + (flush-output) + (and-let* ((dirname (pathname-directory file)) + (directory (make-pathname cache-dir dirname))) + (unless (file-exists? directory) + (create-directory directory #t))) + (call-with-input-request + (add-to-uri file) #f + (lambda (i) + (call-with-output-file + (make-pathname cache-dir file) + (lambda (o) (copy-port i o)))))) + files))) + (else (error "Unknown distribution file type" distribution-file-type)))) (define (download-all-release-files egg-name uris/releases uris) (let ((egg-cache-dir (make-pathname *cache-directory* (->string egg-name)))) @@ -112,8 +110,6 @@ EOF (and-let* ((uri-alias (car uri/releases)) (uri-info (alist-ref uri-alias uris)) (type (car uri-info)) - (downloader (or (alist-ref type dispatchers) - (error "Unknown URI type" type))) (uri-template (cadr uri-info))) (for-each (lambda (egg-release) @@ -136,7 +132,7 @@ EOF (print-error-message exn (current-error-port)) (flush-output (current-error-port))) (create-directory cache-dir #t) - (downloader uri cache-dir)))))) + (download-release type uri cache-dir)))))) (cdr uri/releases)))) uris/releases))) |