diff options
| -rw-r--r-- | henrietta-cache.meta | 9 | ||||
| -rw-r--r-- | henrietta-cache.scm | 151 | ||||
| -rw-r--r-- | henrietta-cache.setup | 8 |
3 files changed, 168 insertions, 0 deletions
diff --git a/henrietta-cache.meta b/henrietta-cache.meta new file mode 100644 index 0000000..8f99dd1 --- /dev/null +++ b/henrietta-cache.meta @@ -0,0 +1,9 @@ +;;;; henrietta-cache.meta -*- Scheme -*- + +((synopsis "Fetch and cache extensions from various sources for Henrietta to consume") + (category egg-tools) + (doc-from-wiki) + (author "Peter Bex") + (depends http-client matchable) + (license "BSD") + (files "henrietta-cache.scm" "henrietta-cache.setup")) 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 diff --git a/henrietta-cache.setup b/henrietta-cache.setup new file mode 100644 index 0000000..9961710 --- /dev/null +++ b/henrietta-cache.setup @@ -0,0 +1,8 @@ +;;;; henrietta-cache.setup -*- Scheme -*- + +(compile -O3 -d0 henrietta-cache.scm) + +(install-program + 'henrietta-cache + '("henrietta-cache") + '((version 0.1))) |