Source

henrietta-cache / henrietta-cache.scm

Full commit
Peter Bex 42a7c9a 
Peter Bex 7f6f521 


Peter Bex b8610e5 
Peter Bex 7f6f521 

Peter Bex 24a720a 


Peter Bex 7f6f521 
Peter Bex b8610e5 

Peter Bex 7f6f521 






mor...@twoticket… 973ee92 







mor...@twoticket… fc837fc 


mor...@twoticket… 973ee92 

mor...@twoticket… fc837fc 

mor...@twoticket… 973ee92 



mor...@twoticket… c0ef6fe 
mor...@twoticket… 973ee92 






Peter Bex 7f6f521 




Peter Bex 21b6d4f 
Peter Bex 7f6f521 

Peter Bex 63f3c7a 
Peter Bex 7f6f521 







Peter Bex ae10d0c 






Peter Bex 47795c1 







Peter Bex ae10d0c 
Peter Bex 3569a27 




























Peter Bex 432e596 



Peter Bex b100d18 
Peter Bex 432e596 





Peter Bex 47795c1 






Peter Bex 432e596 











Peter Bex 42a7c9a 





Peter Bex 432e596 
Peter Bex 47795c1 




Peter Bex 3569a27 
Peter Bex 47795c1 


Peter Bex 3569a27 




Peter Bex f99f1af 






Peter Bex f2ca8d8 





Peter Bex 3569a27 


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 



mor...@twoticket… 973ee92 
mor...@twoticket… fc837fc 



Peter Bex ae10d0c 
mor...@twoticket… 973ee92 

Peter Bex 7f6f521 





Peter Bex 7bbf28c 

mor...@twoticket… fc837fc 
Peter Bex 7bbf28c 
Peter Bex 47795c1 
mor...@twoticket… fc837fc 

Peter Bex 131b7fa 

Peter Bex 7bbf28c 

Peter Bex 7f6f521 
mor...@twoticket… 973ee92 


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 
mor...@twoticket… 973ee92 



Peter Bex 7f6f521 









(use utils posix http-client matchable uri-common srfi-1)

(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))
(define *init-file* #f)

(define download-release-success-hook
  (make-parameter #f))

(define download-release-error-hook
  (make-parameter #f))

(define read-release-info-file-error-hook
  (make-parameter #f))

(define hooks
  `((download-release-success . ,download-release-success-hook)
    (download-release-error   . ,download-release-error-hook)
    (read-release-info-file-error . ,read-release-info-file-error-hook)))

(define (run-hook hook-name . args)
  (and-let* ((hook (or (alist-ref hook-name hooks)
                       (error "invalid hook" hook-name)))
             (hook (hook)))
    (condition-case
        (apply hook args)
      (exn ()
           (print-error-message exn
                                (current-error-port)
                                (sprintf "Error running hook `~A'" hook-name))
           (flush-output (current-error-port))))))

;; 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) "}")
                                      (uri-encode-string (->string (cdr pattern)))))
                              patterns)))

;; We could also use sendfile egg here, but do we want the dependency?
(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)
  (condition-case
      (call-with-input-request
       uri #f (lambda (i) (call-with-output-pipe*
                           cmd
                           (lambda (o) (copy-port i o)))))
    (e (exn http)
       (error (sprintf "Could not download ~A -- ~A"
                       uri (get-condition-property e 'exn 'message))))))

(define (download-files-from-list base-uri files cache-dir)
  (let ((add-to-uri
         (lambda (f)
           (let* ((components (string-split f "/"))
                  (rel (update-uri (uri-reference "") path: components)))
             (uri-relative-to rel base-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)))
       (condition-case
           (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)))))
         (e (exn http)
            (error (sprintf
                    (conc "Could not download file \"~A\", "
                          "listed in meta-file/files-list (full URI: ~A) -- ~A")
                    file (uri->string (add-to-uri file))
                    (get-condition-property e 'exn 'message))))))
     files)))

(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)))
       (condition-case
           (call-with-input-request
            uri #f (lambda (i) (call-with-output-file tmp-zipfile
                                 (lambda (o) (copy-port i o)))))
         (e (exn http)
            (error (sprintf "Could not fetch zip-file ~A -- ~A"
                            uri (get-condition-property e 'exn 'message)))))
       (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))
              (cmd (sprintf "mv ~A/* ~A" (qs contents-dir) (qs cache-dir)))
              (status (system cmd)))
         (system (sprintf "rm -rf ~A" (qs tmpdir)))
         (unless (zero? status)
           (error "Got an error executing command" cmd)))))
    ((meta-file)
     (condition-case
         (let* ((meta (car (call-with-input-request uri #f read-file)))
                (files (alist-ref 'files meta)))
           (unless files
             (error "No \"files\" entry found in meta file" uri))
           (download-files-from-list (uri-reference uri) files cache-dir))
       (e (exn http)
          (error (sprintf "Could not download meta-file \"~A\" -- ~A\n"
                          uri (get-condition-property e 'exn 'message))))))
    ((files-list)
     (condition-case
         (let ((lines (call-with-input-request uri #f read-lines)))
           (when (null? lines)
             (error "Empty files-list file" uri))
	   (let* ((original-uri (uri-reference (car lines)))
                  (path (uri-path original-uri))
                  ;; Ensure base URI is seen as a directory so relative refs
                  ;; are always appended
                  (base-uri (update-uri original-uri
                                        path: (if (string=? "" (last path))
                                                  path
                                                  `(,@path ""))))
                  ;; This works around a strange thing (another one, sigh)
                  ;; that apache-served stuff causes http-client to see an
                  ;; extra \r after the end.  Look into this!
		  (files (delete "" (cdr lines))))
             (download-files-from-list base-uri files cache-dir)))
       (e (exn http)
          (error (sprintf "Could not download files-list \"~A\" -- ~A\n"
                          uri (get-condition-property e 'exn 'message))))))
    (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))
                               (run-hook 'download-release-error
                                         egg-name
                                         egg-release
                                         (get-condition-property exn 'exn 'message)))
                             (create-directory cache-dir #t)
                             (download-release type uri cache-dir)
                             (run-hook 'download-release-success egg-name egg-release))))))
                   (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
    (let ((message (get-condition-property exn 'exn 'message)))
      (fprintf (current-error-port)
               "Could not fetch release-info file for egg ~A from ~A -- ~A\n"
               egg-name uri message)
      (run-hook 'read-release-info-file-error egg-name uri message)
      (flush-output (current-error-port))
      '())
    (with-input-from-request uri #f read-file)))

(define (update-egg-cache)
  (when *init-file*
    (load *init-file*))

  (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)))
                ((or (string=? arg "-i") (string=? arg "-init-file"))
                 (unless (pair? (cdr args)) (usage 1))
                 (set! *init-file* (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))