(use utils posix http-client matchable) (define (usage code) (print #<#EOF usage: henrietta [OPTION ...] -h -help show this message -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' and `REMOTE_ADDR' environment variables, respectively. EOF ));| (define *cache-directory* "cache") (define *egg-list* "egg-locations") (define *chicken-release* (##sys#fudge 41)) ;; This works on raw URI strings, not URI objects (for now?) (define (replace-uri-patterns uri patterns) (string-translate* uri (map (lambda (pattern) (cons (conc "{" (car pattern) "}") (->string (cdr pattern)))) patterns))) ;; We could also use sendfile egg here, once #542 is fixed (define (copy-port in out #!optional limit) (let ((bufsize 1024)) (let loop ((data (read-string (min (or limit bufsize) bufsize) in))) (unless (string-null? data) (display data out) (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)))) (for-each (lambda (uri/releases) (and-let* ((uri-alias (car uri/releases)) (uri-info (alist-ref uri-alias uris)) (type (car uri-info)) (uri-template (cadr uri-info))) (for-each (lambda (egg-release) (let ((cache-dir (make-pathname (list egg-cache-dir "tags") 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) (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))) (define (alist-add! key value alist) (alist-update! key (cons value (alist-ref key alist eq? '())) alist)) (define (update-egg-cache) (for-each (lambda (egg) (let* ((egg-name (car egg)) (egg-uri-template (cadr egg)) (patterns `((egg-name . ,egg-name) (chicken-release . ,*chicken-release*))) (uri (replace-uri-patterns egg-uri-template patterns))) (printf "Caching egg '~A'\n" egg-name) (let collect-releases ((info (with-input-from-request uri #f read-file)) (uris/releases '()) (uris '())) (if (null? info) (download-all-release-files egg-name uris/releases uris) ;; There must be a simpler way to encode optional values (match (car info) (('uri type uri) ; The "default" URI (collect-releases (cdr info) uris/releases (alist-update! 'default (list type uri) uris))) (('uri type uri alias) (collect-releases (cdr info) uris/releases (alist-update! alias (list type uri) uris))) (('release version) ; For the "default" URI (collect-releases (cdr info) (alist-add! 'default version uris/releases) uris)) (('release version alias) (collect-releases (cdr info) (alist-add! alias version uris/releases) uris)) (else (collect-releases (cdr info) uris/releases uris))))))) (call-with-input-file *egg-list* read-file))) (define *short-options* '(#\h #\c #\e)) (define (main args) (let loop ((args args)) (if (null? args) (update-egg-cache) (let ((arg (car args))) (cond ((or (string=? arg "-help") (string=? arg "-h") (string=? arg "--help")) (usage 0)) ((or (string=? arg "-c") (string=? arg "-cache-dir")) (unless (pair? (cdr args)) (usage 1)) (set! *cache-directory* (cadr args)) (loop (cddr args))) ((or (string=? arg "-e") (string=? arg "-egg-list")) (unless (pair? (cdr args)) (usage 1)) (set! *egg-list* (string->symbol (cadr args))) (loop (cddr args))) ((and (positive? (string-length arg)) (char=? #\- (string-ref arg 0))) (if (> (string-length arg) 2) (let ((sos (string->list (substring arg 1)))) (if (null? (lset-intersection eq? *short-options* sos)) (loop (append (map (cut string #\- <>) sos) (cdr args))) (usage 1))) (usage 1))) (else (loop (cdr args)))))))) (main (command-line-arguments))