Implement zipfile-extraction

1 files changed, 57 insertions, 20 deletions

diff --git a/henrietta-cache.scm b/henrietta-cache.scm
index f1efe54..9065650 100644
--- a/henrietta-cache.scm
+++ b/henrietta-cache.scm
@@ -1,7 +1,3 @@
-;(module henrietta-cache ()
-
-(import chicken scheme)
-
 (use utils posix http-client matchable)
 
 (define (usage code)
@@ -12,7 +8,7 @@ usage: henrietta [OPTION ...]
   -c   -cache-dir LOCATION      put the egg cache in this directory
   -e   -egg-list  LOCATION      file containing the master list of available eggs
 
-  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING' 
+  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING'
 and `REMOTE_ADDR' environment variables, respectively.
 
 EOF
@@ -38,10 +34,53 @@ EOF
              (when limit (set! limit (- limit (string-length data))))
              (loop (read-string (min (or limit bufsize) bufsize) in))))))
 
+(define (call-with-output-pipe* cmd proc)
+  (let ([p (open-output-pipe cmd)])
+    (proc p)
+    (unless (zero? (close-output-pipe p))
+      (error "Got an error while executing command " cmd))))
+
+(define (pipe-from-http uri cmd)
+  (call-with-input-request
+   uri #f (lambda (i) (call-with-output-pipe*
+                        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)))))))))
+
 (define (download-all-release-files egg-name uris/releases uris)
   (let ((egg-cache-dir (make-pathname *cache-directory* (->string egg-name))))
-    (unless (directory? egg-cache-dir)
-      (create-directory egg-cache-dir #t))
     (for-each (lambda (uri/releases)
                 (and-let* ((uri-alias (car uri/releases))
                            (uri-info (alist-ref uri-alias uris))
@@ -49,22 +88,22 @@ EOF
                            (uri-template (cadr uri-info)))
                   (for-each
                    (lambda (egg-release)
-                     (let ((cached-file (make-pathname egg-cache-dir
-                                                       egg-release
-                                                       (->string type))))
-                       (unless (file-exists? cached-file)
+                     (let ((cache-dir (make-pathname egg-cache-dir egg-release)))
+                       (unless (file-exists? cache-dir)
                          (let* ((patterns `((egg-name . ,egg-name)
                                             (egg-release . ,egg-release)
                                             (chicken-release . ,*chicken-release*)))
                                 (uri (replace-uri-patterns uri-template patterns)))
                            (printf "\tDownloading release ~A from ~A\n"
                                    egg-release uri)
-                           ;; Here we should dispatch on type to determine what to do!
-                           (call-with-input-request
-                            uri #f (lambda (i)
-                                     (call-with-output-file
-                                         cached-file
-                                       (lambda (o) (copy-port i o)))))))))
+                           (handle-exceptions exn
+                             (begin
+                               (system (sprintf "rm -rf ~A" cache-dir))
+                               (printf "Error downloading or extracting egg '~A' release ~A: "
+                                       egg-name egg-release)
+                               (print-error-message exn))
+                             (create-directory cache-dir #t)
+                             ((alist-ref type dispatchers eq? void) uri cache-dir))))))
                    (cdr uri/releases))))
               uris/releases)))
 
@@ -111,7 +150,7 @@ EOF
     (if (null? args)
         (update-egg-cache)
         (let ((arg (car args)))
-          (cond ((or (string=? arg "-help") 
+          (cond ((or (string=? arg "-help")
                      (string=? arg "-h")
                      (string=? arg "--help"))
                  (usage 0))
@@ -134,5 +173,3 @@ EOF
                 (else (loop (cdr args))))))))
 
 (main (command-line-arguments))
-
-;)
\ No newline at end of file