diff options
| -rw-r--r-- | henrietta-cache.scm | 36 |
1 files changed, 23 insertions, 13 deletions
diff --git a/henrietta-cache.scm b/henrietta-cache.scm index 1771f5b..9daa883 100644 --- a/henrietta-cache.scm +++ b/henrietta-cache.scm @@ -83,6 +83,23 @@ EOF (error (sprintf "Could not download ~A -- ~A" uri (get-condition-property e 'exn 'message)))))) +;; this moves via copy delete as it produces more consistent results +;; (i.e. like new file) in particular bsd group ownership is more natural +(define (move-to-cache tmp-dir cache-dir) + (create-directory cache-dir) + (for-each + (lambda (file) + (let + ((tmp-file (make-pathname tmp-dir file)) + (cache-file (make-pathname cache-dir file))) + (if (directory-exists? tmp-file) + (move-to-cache tmp-file cache-file) + (begin + (copy-file tmp-file cache-file) + (delete-file tmp-file) )))) + (directory tmp-dir) ) + (delete-directory tmp-dir #t) ) ;nb: don't like recursive but top level has hidden contents and don't want those + (define (download-files-from-list base-uri files cache-dir) (let ((tmp-dir (create-temporary-directory)) (add-to-uri @@ -114,13 +131,9 @@ EOF "listed in meta-file/files-list (full URI: ~A) -- ~A") file (uri->string (add-to-uri file)) (get-condition-property e 'exn 'message)))))) - files) + 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))))))) + (move-to-cache tmp-dir cache-dir) ))) ;; Make-cmd is a lambda which accepts the temporary file- and dirname ;; and returns a suitable command to execute using SYSTEM @@ -154,13 +167,10 @@ EOF ("pax_global_header" dir) (dir)) (make-pathname tmp-dir dir)) - (else tmp-dir))) - (cmd (sprintf "mv ~A/* ~A" (qs contents-dir) (qs cache-dir))) - (status (system cmd))) - (unless (zero? status) - (error "Got an error executing command" cmd)) - (delete-file tmp-file) - (system (sprintf "rm -rf ~A" (qs tmp-dir))))))) + (else tmp-dir)))) + (move-to-cache contents-dir cache-dir) + (delete-directory tmp-dir #t) ; sloppy; don't know which dir selected + (delete-file tmp-file) )))) (define (download-release distribution-file-type uri cache-dir) (case distribution-file-type |