(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 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)
(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)
((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)
(flush-output)
(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)))
(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))))))))
(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))