summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPeter Bex <peter@more-magic.net>2019-09-01 17:19:48 +0200
committerPeter Bex <peter@more-magic.net>2019-09-01 17:19:48 +0200
commitc8599d995ec8653976a9ab9c9197f246fedecc05 (patch)
tree6943c3df15952deb2fe02a4eca71f0a7780b009f
parent2bf7dae92529bb34c873c032271fdd2c17ab9cc3 (diff)
downloadhenrietta-cache-c8599d995ec8653976a9ab9c9197f246fedecc05.tar.gz
Don't use "tmp" and copy instead of move to improve permission handling1.4
tmp causes warnings when linking on OpenBSD. Group ownership switches to the directory and warns when moving (on OpenBSD and possibly other BSDs, too). Thanks to "n0goOi3"
-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