summaryrefslogtreecommitdiff
path: root/henrietta-cache.scm
diff options
context:
space:
mode:
Diffstat (limited to 'henrietta-cache.scm')
-rw-r--r--henrietta-cache.scm36
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