Source

henrietta-cache / henrietta-cache.scm

Full commit
Peter Bex 24a720a 
Peter Bex 7f6f521 


Peter Bex b8610e5 
Peter Bex 7f6f521 

Peter Bex 24a720a 


Peter Bex 7f6f521 
Peter Bex b8610e5 

Peter Bex 7f6f521 























Peter Bex ae10d0c 











Peter Bex 432e596 



Peter Bex b100d18 
Peter Bex 432e596 


















































Peter Bex ae10d0c 
Peter Bex 7f6f521 








Peter Bex e5cfe86 

Peter Bex ae10d0c 
Peter Bex 580e5c5 





Peter Bex 24a720a 
Peter Bex ae10d0c 


Peter Bex 24a720a 




Peter Bex ae10d0c 
Peter Bex 432e596 
Peter Bex 7f6f521 





Peter Bex 7bbf28c 





Peter Bex 131b7fa 

Peter Bex 7bbf28c 

Peter Bex 7f6f521 







Peter Bex 580e5c5 
Peter Bex 24a720a 

Peter Bex 7bbf28c 


























Peter Bex 24a720a 



Peter Bex 7f6f521 
Peter Bex b0c1749 

Peter Bex 7f6f521 




Peter Bex ae10d0c 
Peter Bex 7f6f521 




Peter Bex b0c1749 
Peter Bex 7f6f521 


Peter Bex 24a720a 
Peter Bex 7f6f521 










(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, 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 (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)
  (call-with-input-request
   uri #f (lambda (i) (call-with-output-pipe*
                        cmd
                        (lambda (o) (copy-port i o))))))

(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)))
       (call-with-input-request
        uri #f (lambda (i) (call-with-output-file tmp-zipfile
                             (lambda (o) (copy-port i o)))))
       (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)
     (let* ((meta (car (call-with-input-request uri #f read-file)))
            (uri (uri-reference uri))
            (add-to-uri
             (lambda (f)
               (let* ((components (string-split f "/"))
                      (rel (update-uri (uri-reference "") path: components)))
                 (uri-relative-to rel uri))))
            (files (alist-ref 'files meta)))
       (unless files
         (error "No \"files\" entry found in meta file" 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)))
          (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))))))
        files)))
    (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\n"
               egg-name uri)
      (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))