diff options
Diffstat (limited to 'henrietta-cache.scm')
| -rw-r--r-- | henrietta-cache.scm | 77 |
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 |