From b419489ff568885b46c06fe2d9d31be07f1e07a8 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 19 Mar 2011 23:47:27 +0100 Subject: Initial, currently broken, version --- henrietta-cache.scm | 151 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 151 insertions(+) create mode 100644 henrietta-cache.scm (limited to 'henrietta-cache.scm') diff --git a/henrietta-cache.scm b/henrietta-cache.scm new file mode 100644 index 0000000..e8beb01 --- /dev/null +++ b/henrietta-cache.scm @@ -0,0 +1,151 @@ +;(module henrietta-cache () + +(import chicken scheme) + +(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 (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)) + (type (car uri-info)) + (uri-template (cadr uri-info))) + (for-each + (lambda (egg-release) + (let* ((patterns `((egg-name . ,egg-name) + (egg-release . ,egg-release) + (chicken-release . ,*chicken-release*))) + (uri (replace-uri-patterns uri-template patterns))) + (printf "Downloading egg ~A, release ~A from ~A...\n" + egg-name 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 + (make-pathname egg-cache-dir egg-release) + (lambda (o) (copy-port i o))))))) + (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))) + (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 (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-dir* (cadr args)) + (loop (cddr args))) + ((or (string=? arg "-t") (string=? arg "-transport")) + (unless (pair? (cdr args)) (usage 1)) + (set! *default-transport* (string->symbol (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))) + ((string=? "-username" arg) + (unless (pair? (cdr args)) (usage 1)) + (set! *username* (cadr args)) + (loop (cddr args))) + ((string=? "-password" arg) + (unless (pair? (cdr args)) (usage 1)) + (set! *password* (cadr args)) + (loop (cddr args))) + ((string=? "-query" arg) + (unless (pair? (cdr args)) (usage 1)) + (set! *query-string* (cadr args)) + (loop (cddr args))) + ((string=? "-remote" arg) + (unless (pair? (cdr args)) (usage 1)) + (set! *remote-addr* (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)) + +;) \ No newline at end of file -- cgit v1.2.3