summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2011-03-20 16:23:49 +0100
committerPeter Bex <peter@more-magic.net>2011-03-20 16:23:49 +0100
commit0ae3c447c2c94ea1399a4aa570c38af345a3f00d (patch)
tree2bdbef30edd6fbe9359c08d8797fe3d6f99ae3d5
parent257756f811e7e7dbab06f656f89fb59d1b5f2382 (diff)
downloadhenrietta-cache-0ae3c447c2c94ea1399a4aa570c38af345a3f00d.tar.gz
Implement zipfile-extraction
-rw-r--r--henrietta-cache.scm77
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