summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2011-05-26 22:48:01 +0200
committerPeter Bex <peter@more-magic.net>2011-05-26 22:48:01 +0200
commit46da50c36890a4ed2fe7a05773a103fe71c523d3 (patch)
tree23a173a849c63a748f74c2b882a87da384626c88
parent0623b16a144d60414b25b64789365b8c2bc7bfab (diff)
downloadhenrietta-cache-0.2.tar.gz
Add flat file list type to replace meta-files. This first lists a base URI and then a list of files, one per line0.2
-rw-r--r--henrietta-cache.scm68
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)