(use utils posix http-client matchable uri-common) (define (usage code) (print #<#EOF usage: henrietta-cache [OPTION ...] -h -help show this message -c -cache-dir CACHEDIR put egg cache in this dir, defaults to "cache" -e -egg-list EGGLIST file containing the master list of available eggs, defaults to "egg-locations". Can be an URI Henrietta-cache will download cached copies of each egg listed in the file EGGLIST, to CACHEDIR. 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 (download-release distribution-file-type uri cache-dir) (case distribution-file-type ((targz) (pipe-from-http uri (sprintf "(cd ~A; zcat | 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)))) (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) (flush-output) (handle-exceptions exn (begin (system (sprintf "rm -rf ~A" cache-dir)) (fprintf (current-error-port) "Error downloading or extracting egg '~A' release ~A: " egg-name egg-release) (print-error-message exn (current-error-port)) (flush-output (current-error-port))) (create-directory cache-dir #t) (download-release type 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 (read-release-info-file uri egg-name) (handle-exceptions exn (begin (fprintf (current-error-port) "Could not fetch release-info file for egg ~A from ~A\n" egg-name uri) (flush-output (current-error-port)) '()) (with-input-from-request uri #f read-file))) (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) (flush-output) (handle-exceptions exn (begin (fprintf (current-error-port) "----\n") (fprintf (current-error-port) "Error downloading egg ~A\n" egg-name) (print-error-message exn (current-error-port)) (fprintf (current-error-port) "----\n") (flush-output (current-error-port))) (let collect-releases ((info (read-release-info-file uri egg-name)) (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)))))))) (let ((uri (uri-reference *egg-list*))) (if (absolute-uri? uri) ; Assume this is a http reference then (call-with-input-request uri #f read-file) (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* (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))