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

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)