Source

henrietta-cache / henrietta-cache.scm

(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)
  (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-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)))
         (rename-file contents-dir cache-dir)
         (system (sprintf "rm -rf ~A" (qs tmpdir))))))
    ((meta-file)
     (condition-case
         (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)))
              (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 (full URI: ~A) -- ~A")
                           file (uri->string (add-to-uri file))
                           (get-condition-property e 'exn 'message))))))
            files))
       (e (exn http)
          (error (sprintf "Could not download meta-file \"~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)))
                             (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 -- ~A\n"
               egg-name uri (get-condition-property exn 'exn 'message))
      (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))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.