Don't unneccessarily use an alist for the distribution types

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)))