summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2011-03-19 23:47:27 +0100
committerPeter Bex <peter@more-magic.net>2011-03-19 23:47:27 +0100
commitb419489ff568885b46c06fe2d9d31be07f1e07a8 (patch)
treec7cd0a23ca100f31b33f6e5929cdb8a606176863
downloadhenrietta-cache-b419489ff568885b46c06fe2d9d31be07f1e07a8.tar.gz
Initial, currently broken, version
-rw-r--r--henrietta-cache.meta9
-rw-r--r--henrietta-cache.scm151
-rw-r--r--henrietta-cache.setup8
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)))