diff options
Diffstat (limited to 'guix/build/store-copy.scm')
-rw-r--r-- | guix/build/store-copy.scm | 51 |
1 files changed, 46 insertions, 5 deletions
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 2d9590d16f..549aa4f28b 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -19,6 +19,7 @@ (define-module (guix build store-copy) #:use-module (guix build utils) #:use-module (guix sets) + #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -167,7 +168,30 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) -(define* (populate-store reference-graphs target) +(define (reset-permissions file) + "Reset the permissions on FILE and its sub-directories so that they are all +read-only." + ;; XXX: This procedure exists just to work around the inability of + ;; 'copy-recursively' to preserve permissions. + (file-system-fold (const #t) ;enter? + (lambda (file stat _) ;leaf + (unless (eq? 'symlink (stat:type stat)) + (chmod file + (if (zero? (logand (stat:mode stat) + #o100)) + #o444 + #o555)))) + (const #t) ;down + (lambda (directory stat _) ;up + (chmod directory #o555)) + (const #f) ;skip + (const #f) ;error + #t + file + lstat)) + +(define* (populate-store reference-graphs target + #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." (define store @@ -183,9 +207,26 @@ REFERENCE-GRAPHS, a list of reference-graph files." (mkdir-p store) (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append target thing))) - (things-to-copy))) + + (let* ((things (things-to-copy)) + (len (length things)) + (progress (progress-reporter/bar len + (format #f "copying ~a store items" + len) + log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing) + #:keep-mtime? #t + #:log (%make-void-port "w")) + + ;; XXX: Since 'copy-recursively' doesn't allow us to + ;; preserve permissions, we have to traverse TARGET to + ;; make sure everything is read-only. + (reset-permissions (string-append target thing)) + (report)) + things))))) ;;; store-copy.scm ends here |