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