From 8d846470f2201b47485f6239e8746d5a6ee2c0a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Apr 2014 00:08:54 +0200 Subject: build-system/gnu: Reset timestamps on build tree when source is a directory. * guix/build/utils.scm (copy-recursively): Add #:keep-mtime? parameter and honor it. * guix/build/gnu-build-system.scm (unpack): Use #:keep-mtime? #t. * gnu/packages/admin.scm (shadow)[arguments]: Remove 'reset-timestamps' phase. --- guix/build/gnu-build-system.scm | 6 +++++- guix/build/utils.scm | 18 +++++++++++++----- 2 files changed, 18 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index da6b31c326..8636931ed9 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -97,7 +97,11 @@ working directory." (begin (mkdir "source") (chdir "source") - (copy-recursively source ".") + + ;; Preserve timestamps (set to the Epoch) on the copied tree so that + ;; things work deterministically. + (copy-recursively source "." + #:keep-mtime? #t) #t) (and (zero? (system* "tar" "xvf" source)) (chdir (first-subdirectory "."))))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 40af785b88..9779278167 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -134,9 +134,12 @@ return values of applying PROC to the port." (define* (copy-recursively source destination #:key (log (current-output-port)) - (follow-symlinks? #f)) + (follow-symlinks? #f) + keep-mtime?) "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? -is true; otherwise, just preserve them. Write verbose output to the LOG port." +is true; otherwise, just preserve them. When KEEP-MTIME? is true, keep the +modification time of the files in SOURCE on those of DESTINATION. Write +verbose output to the LOG port." (define strip-source (let ((len (string-length source))) (lambda (file) @@ -152,10 +155,15 @@ is true; otherwise, just preserve them. Write verbose output to the LOG port." (let ((target (readlink file))) (symlink target dest))) (else - (copy-file file dest))))) + (copy-file file dest) + (when keep-mtime? + (set-file-time dest stat)))))) (lambda (dir stat result) ; down - (mkdir-p (string-append destination - (strip-source dir)))) + (let ((target (string-append destination + (strip-source dir)))) + (mkdir-p target) + (when keep-mtime? + (set-file-time target stat)))) (lambda (dir stat result) ; up result) (const #t) ; skip -- cgit v1.2.3 From d84a7be6675bd647931d8eff9134d00dd5a6bd58 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 May 2014 14:45:58 +0200 Subject: utils: 'delete-file-recursively' doesn't follow mount points by default. * guix/build/utils.scm (delete-file-recursively): Add #:follow-mounts? parameter and honor it. --- guix/build/utils.scm | 43 ++++++++++++++++++++++++------------------- 1 file changed, 24 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 9779278167..2f3dc9cad0 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -178,25 +178,30 @@ verbose output to the LOG port." stat lstat))) -(define (delete-file-recursively dir) - "Delete DIR recursively, like `rm -rf', without following symlinks. Report -but ignore errors." - (file-system-fold (const #t) ; enter? - (lambda (file stat result) ; leaf - (delete-file file)) - (const #t) ; down - (lambda (dir stat result) ; up - (rmdir dir)) - (const #t) ; skip - (lambda (file stat errno result) - (format (current-error-port) - "warning: failed to delete ~a: ~a~%" - file (strerror errno))) - #t - dir - - ;; Don't follow symlinks. - lstat)) +(define* (delete-file-recursively dir + #:key follow-mounts?) + "Delete DIR recursively, like `rm -rf', without following symlinks. Don't +follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore +errors." + (let ((dev (stat:dev (lstat dir)))) + (file-system-fold (lambda (dir stat result) ; enter? + (or follow-mounts? + (= dev (stat:dev stat)))) + (lambda (file stat result) ; leaf + (delete-file file)) + (const #t) ; down + (lambda (dir stat result) ; up + (rmdir dir)) + (const #t) ; skip + (lambda (file stat errno result) + (format (current-error-port) + "warning: failed to delete ~a: ~a~%" + file (strerror errno))) + #t + dir + + ;; Don't follow symlinks. + lstat))) (define (find-files dir regexp) "Return the lexicographically sorted list of files under DIR whose basename -- cgit v1.2.3 From f986c264b2502df5376f4c50ff104b5fc8db9f23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 7 Jun 2014 19:35:20 +0200 Subject: build-system/gnu: Add 'package-with-restricted-references'. * guix/build-system/gnu.scm (package-with-restricted-references): New procedure. --- guix/build-system/gnu.scm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 0c3f1ea4e3..4fa1d1683d 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -33,7 +33,8 @@ package-with-extra-configure-variable static-libgcc-package static-package - dist-package)) + dist-package + package-with-restricted-references)) ;; Commentary: ;; @@ -190,6 +191,15 @@ runs `make distcheck' and whose result is one or more source tarballs." ("gettext" ,(ref '(gnu packages gettext) 'gnu-gettext)) ("texinfo" ,(ref '(gnu packages texinfo) 'texinfo)))))))) +(define (package-with-restricted-references p refs) + "Return a package whose outputs are guaranteed to only refer to the packages +listed in REFS." + (if (eq? (package-build-system p) gnu-build-system) ; XXX: dirty + (package (inherit p) + (arguments `(#:allowed-references ,refs + ,@(package-arguments p)))) + p)) + (define %store ;; Store passed to STANDARD-INPUTS. -- cgit v1.2.3 From eef4096c14568deae818287d23ad5da6a2f41d92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Jun 2014 23:19:01 +0200 Subject: guix system: 'init' makes sure the target store directory exists. * guix/scripts/system.scm (install): Before calling 'copy-closure', make sure directory (%store-prefix) under TARGET exists. --- guix/scripts/system.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 345d8c3e5f..7a4a2a6a06 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -100,9 +100,13 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG." (if (string=? target "/") (warning (_ "initializing the current root file system~%")) - ;; Copy items to the new store. - (for-each (cut copy-closure store <> target #:log-port log-port) - to-copy)) + (begin + ;; Make sure the target store exists. + (mkdir-p (string-append target (%store-prefix))) + + ;; Copy items to the new store. + (for-each (cut copy-closure store <> target #:log-port log-port) + to-copy))) ;; Create a bunch of additional files. (format log-port "populating '~a'...~%" target) -- cgit v1.2.3 From 00fe93338d5cd29b4d565749b5842a7477d0477c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Jun 2014 23:35:21 +0200 Subject: substitute-binary: Warn about uninitialized ACL. * guix/scripts/substitute-binary.scm (guix-substitute-binary): Call 'check-acl-initialized'. (check-acl-initialized): Don't rely on 'equal?' to compare keys. Instead, convert keys to strings. --- guix/scripts/substitute-binary.scm | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index c70a4f626c..e2167c63cb 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -592,9 +592,14 @@ Internal tool to substitute a pre-built binary to a local build.\n")) (let ((key (call-with-input-file %public-key-file (compose string->canonical-sexp get-string-all)))) - (equal? (acl->public-keys acl) (list key))))) - - (let ((acl (current-acl))) + (match acl + ((thing) + (equal? (canonical-sexp->string thing) + (canonical-sexp->string key))) + (_ + #f))))) + + (let ((acl (acl->public-keys (current-acl)))) (when (or (null? acl) (singleton? acl)) (warning (_ "ACL for archive imports seems to be uninitialized, \ substitutes may be unavailable\n"))))) @@ -603,6 +608,7 @@ substitutes may be unavailable\n"))))) "Implement the build daemon's substituter protocol." (mkdir-p %narinfo-cache-directory) (maybe-remove-expired-cached-narinfo) + (check-acl-initialized) ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly ;; when we know we cannot substitute, but we must emit a newline on stdout -- cgit v1.2.3