From bfd5c7a25d334b456c36acc3fe6562b5b89d947f Mon Sep 17 00:00:00 2001
From: Peter Bex <peter@more-magic.net>
Date: Tue, 1 Oct 2013 20:28:38 +0200
Subject: Download files from file-list types to a tmpdir and move them once
 completed.

This ensures that when we crap out mid-way for some reason, we won't
leave an empty or half-populated directory around, which would cause
it to skip the dir instead of trying again on the next run.

(File-list types are meta-file or plaintext flat file listing)
---
 henrietta-cache.scm | 59 ++++++++++++++++++++++++++++++-----------------------
 1 file changed, 34 insertions(+), 25 deletions(-)

diff --git a/henrietta-cache.scm b/henrietta-cache.scm
index ce2ed93..58d7f90 100644
--- a/henrietta-cache.scm
+++ b/henrietta-cache.scm
@@ -80,34 +80,43 @@ EOF
                        uri (get-condition-property e 'exn 'message))))))
 
 (define (download-files-from-list base-uri files cache-dir)
-  (let ((add-to-uri
+  (let ((tmp-dir (create-temporary-directory))
+        (add-to-uri
          (lambda (f)
            (let* ((components (string-split f "/"))
                   (rel (update-uri (uri-reference "") path: components)))
              (uri-relative-to rel base-uri)))))
-    (create-directory cache-dir #t)     ; TODO: Download to tmpdir, then move
-    (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)))
+    (handle-exceptions exn
+        (begin (system (sprintf "rm -rf ~A" (qs tmp-dir)))
+               (signal exn))
+      (for-each
+       (lambda (file)
+         (printf "\t\t~A...\n" file)
+         (flush-output)
+         (and-let* ((dirname (pathname-directory file))
+                    (directory (make-pathname tmp-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 tmp-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)
+      (create-directory cache-dir #t)
+      (let* ((cmd (sprintf "mv ~A/* ~A" (qs tmp-dir) (qs cache-dir)))
+             (status (system cmd)))
+        (unless (zero? status)
+          (error "Got an error executing command" cmd))
+        (system (sprintf "rm -rf ~A" (qs tmp-dir)))))))
 
 ;; Make-cmd is a lambda which accepts the temporary file- and dirname
 ;; and returns a suitable command to execute using SYSTEM
@@ -212,7 +221,7 @@ EOF
                            (flush-output)
                            (handle-exceptions exn
                              (begin
-                               (system (sprintf "rm -rf ~A" cache-dir))
+                               (system (sprintf "rm -rf ~A" (qs cache-dir)))
                                (fprintf (current-error-port)
                                         "Error downloading or extracting egg '~A' release ~A: "
                                         egg-name egg-release)
-- 
cgit v1.2.3