1. Peter Bex
  2. henrietta-cache


henrietta-cache / henrietta-cache.scm

;(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.


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

;; 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)))
                   (lambda (egg-release)
                     (let ((cached-file (make-pathname egg-cache-dir
                                                       (->string type))))
                       (unless (file-exists? cached-file)
                         (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)
                           ;; Here we should dispatch on type to determine what to do!
                            uri #f (lambda (i)
                                       (lambda (o) (copy-port i o)))))))))
                   (cdr uri/releases))))

(define (alist-add! key value alist)
  (alist-update! key (cons value (alist-ref key alist eq? '())) alist))

(define (update-egg-cache)
   (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)
       (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)
               (('release version alias)
                (collect-releases (cdr info)
                                  (alist-add! alias version uris/releases)
               (else (collect-releases (cdr info) uris/releases uris)))))))
   (call-with-input-file *egg-list* read-file)))

(define *short-options* '(#\h #\c #\e))

(define (main args)
  (let loop ((args args))
    (if (null? args)
        (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* (string->symbol (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))