summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2011-03-20 20:49:57 +0100
committerPeter Bex <peter@more-magic.net>2011-03-20 20:49:57 +0100
commita4a89a58de492a93ecff9c2c18c52dda6aa0c6b9 (patch)
tree47813dbfa87d2e7cd2709fe22f2cd1acf2902053
parent24ffacf4b7df4f572a4c51ca6d87d120d24a17d2 (diff)
downloadhenrietta-cache-a4a89a58de492a93ecff9c2c18c52dda6aa0c6b9.tar.gz
Don't unneccessarily use an alist for the distribution types
-rw-r--r--henrietta-cache.scm118
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)))