diff options
Diffstat (limited to 'henrietta-cache.scm')
| -rw-r--r-- | henrietta-cache.scm | 68 |
1 files changed, 40 insertions, 28 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index 2a51f35..2f1c7cf 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -51,6 +51,35 @@ EOF (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) @@ -87,40 +116,23 @@ EOF ((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)) + (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)) + (download-files-from-list (uri-reference (car lines)) + (cdr lines) 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) |