(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, but do we want the dependency?
(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)
(condition-case
(call-with-input-request
uri #f (lambda (i) (call-with-output-pipe*
cmd
(lambda (o) (copy-port i o)))))
(e (exn http)
(error (sprintf "Could not download ~A -- ~A"
uri (get-condition-property e 'exn 'message))))))
(define (download-files-from-list base-uri files cache-dir)
(let ((add-to-uri
(lambda (f)
(let* ((components (string-split f "/"))
(rel (update-uri (uri-reference "") path: components)))
(uri-relative-to rel base-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)))
(condition-case
(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)))))
(e (exn http)
(error (sprintf
(conc "Could not download file \"~A\", "
"listed in meta-file/files-list (full URI: ~A) -- ~A")
file (uri->string (add-to-uri file))
(get-condition-property e 'exn 'message))))))
files)))
(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)))
(condition-case
(call-with-input-request
uri #f (lambda (i) (call-with-output-file tmp-zipfile
(lambda (o) (copy-port i o)))))
(e (exn http)
(error (sprintf "Could not fetch zip-file ~A -- ~A"
uri (get-condition-property e 'exn 'message)))))
(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)
(condition-case
(let* ((meta (car (call-with-input-request uri #f read-file)))
(files (alist-ref 'files meta)))
(unless files
(error "No \"files\" entry found in meta file" uri))
(download-files-from-list (uri-reference uri) files cache-dir))
(e (exn http)
(error (sprintf "Could not download meta-file \"~A\" -- ~A\n"
uri (get-condition-property e 'exn 'message))))))
((files-list)
(condition-case
(let ((lines (call-with-input-request uri #f read-lines)))
(when (null? lines)
(error "Empty files-list file" uri))
(download-files-from-list (uri-reference (car lines))
(cdr lines) cache-dir))
(e (exn http)
(error (sprintf "Could not download files-list \"~A\" -- ~A\n"
uri (get-condition-property e 'exn 'message))))))
(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 -- ~A\n"
egg-name uri (get-condition-property exn 'exn 'message))
(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))