From 5f7dd092ca577a534067f577b8849ed06cabf970 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Nov 2018 22:52:19 +0100 Subject: pull: Make '--dry-run' behave as expected. * guix/scripts/pull.scm (show-help): Document '--dry-run'. (build-and-install): Add #:dry-run? parameter and honor it. (guix-pull): Remove (assoc-ref opts 'dry-run?) condition. Instead, pass it as #:dry-run? to 'build-and-install'. * doc/guix.texi (Invoking guix pull): Document '--dry-run'. Move '--verbose' to the bottom. --- guix/scripts/pull.scm | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 188237aa90..aff4f378be 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -86,6 +86,8 @@ (define (show-help) list generations matching PATTERN")) (display (G_ " -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) + (display (G_ " + -n, --dry-run show what would be pulled and built")) (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) @@ -164,15 +166,18 @@ (define (display-profile-news profile) (_ #t))) (define* (build-and-install instances profile - #:key verbose?) - "Build the tool from SOURCE, and install it in PROFILE." + #:key verbose? dry-run?) + "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is +true, display what would be built without actually building it." (define update-profile (store-lift build-and-use-profile)) (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad - (update-profile profile manifest) - (return (display-profile-news profile))))) + (update-profile profile manifest + #:dry-run? dry-run?) + (munless dry-run? + (display-profile-news profile))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -497,8 +502,6 @@ (define (guix-pull . args) (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) - ((assoc-ref opts 'dry-run?) - #t) ;XXX: not very useful (else (with-store store (with-status-report print-build-event @@ -531,6 +534,8 @@ (define (guix-pull . args) (canonical-package guile-2.2))))) (run-with-store store (build-and-install instances profile + #:dry-run? + (assoc-ref opts 'dry-run?) #:verbose? (assoc-ref opts 'verbose?)))))))))))))) -- cgit v1.2.3 From cbe7387c0423294265faca7d3c648ee88a7baad5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Nov 2018 22:58:19 +0100 Subject: self: Remove extra paren in manual version string. * guix/self.scm (info-manual)[build]: Remove extra closing paren in VERSION. --- guix/self.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index ecf846490f..40ef528ffd 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -290,7 +290,7 @@ (define build ;; doesn't change at each commit? (call-with-output-file "version.texi" (lambda (port) - (let ((version "0.0-git)")) + (let ((version "0.0-git")) (format port " @set UPDATED 1 January 1970 @set UPDATED-MONTH January 1970 -- cgit v1.2.3 From 8d3beb3a44b619d46715dbc4ccad4acfe0a1dcde Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Nov 2018 23:26:37 +0100 Subject: self: Install substitute keys. * guix/self.scm (whole-package): Add #:substitute-keys and honor it. (compiled-guix): Pass #:substitute-keys to 'whole-package' when PULL-VERSION is one. --- guix/self.scm | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 40ef528ffd..4548e6c044 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -408,7 +408,8 @@ (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) compiled-modules - info daemon guile + info daemon substitute-keys + guile (command (guix-command modules #:dependencies dependencies #:guile guile @@ -430,6 +431,13 @@ (define* (whole-package name modules dependencies (symlink (string-append #$daemon "/bin/guix-daemon") (string-append #$output "/bin/guix-daemon"))) + (when #$substitute-keys + (mkdir-p (string-append #$output "/share/guix")) + (copy-recursively #$substitute-keys + (string-append #$output + "/share/guix") + #:log (%make-void-port "w"))) + (let ((modules (string-append #$output "/share/guile/site/" (effective-version))) @@ -666,6 +674,8 @@ (define (built-modules node-subset) 'guix-daemon) #:info (info-manual source) + #:substitute-keys (sub-directory source + "etc/substitutes") #:guile-version guile-version))) ((= 0 pull-version) ;; Legacy 'guix pull': return the .scm and .go files as one -- cgit v1.2.3 From 2e4d83398b9e0f7c32d2a2f4184a60da0a7819f5 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 5 Nov 2018 00:01:47 -0500 Subject: ssh: Honor the SOCKET-NAME argument of connect-to-remote-daemon. * guix/ssh.scm (connect-to-remote-daemon): Pass the `socket-name' variable to the `open-connection' call so that it is honored. --- guix/ssh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index da20d4d8db..25ec8295e8 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -161,7 +161,7 @@ (define* (connect-to-remote-daemon session "/var/guix/daemon-socket/socket")) "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, an SSH session. Return a object." - (open-connection #:port (remote-daemon-channel session))) + (open-connection #:port (remote-daemon-channel session socket-name))) (define (store-import-channel session) -- cgit v1.2.3 From 6cf502d164a47fa38e2fa63972409e97c06c288c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Nov 2018 09:35:06 +0100 Subject: self: Rename 'sub-directory' to 'file-append*'. * guix/self.scm (sub-directory): Rename to... (file-append*): ... this. Add #:recursive? parameter and pass it to 'local-file'. (locale-data, info-manual, compiled-guix): Adjust accordingly. --- guix/self.scm | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 4548e6c044..43223972c6 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -206,21 +206,22 @@ (define (file-imports directory sub-directory pred) (local-file file #:recursive? #t))) (find-files (string-append directory "/" sub-directory) pred))) -(define* (sub-directory item sub-directory) - "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like -object." +(define* (file-append* item file #:key (recursive? #t)) + "Return FILE within ITEM, which may be a file name or a file-like object. +When ITEM is a plain file name (a string), simply return a 'local-file' +record with the new file name." (match item ((? string?) ;; This is the optimal case: we return a new "source". Thus, a ;; derivation that depends on this sub-directory does not depend on ITEM ;; itself. - (local-file (string-append item "/" sub-directory) - #:recursive? #t)) + (local-file (string-append item "/" file) + #:recursive? recursive?)) ;; TODO: Add 'local-file?' case. (_ ;; In this case, anything that refers to the result also depends on ITEM, ;; which isn't great. - (file-append item "/" sub-directory)))) + (file-append item "/" file)))) (define* (locale-data source domain #:optional (directory domain)) @@ -238,7 +239,7 @@ (define build (ice-9 match) (ice-9 ftw)) (define po-directory - #+(sub-directory source (string-append "po/" directory))) + #+(file-append* source (string-append "po/" directory))) (define (compile language) (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" @@ -273,10 +274,10 @@ (define graphviz 'graphviz)) (define documentation - (sub-directory source "doc")) + (file-append* source "doc")) (define examples - (sub-directory source "gnu/system/examples")) + (file-append* source "gnu/system/examples")) (define build (with-imported-modules '((guix build utils)) @@ -674,8 +675,8 @@ (define (built-modules node-subset) 'guix-daemon) #:info (info-manual source) - #:substitute-keys (sub-directory source - "etc/substitutes") + #:substitute-keys (file-append* source + "etc/substitutes") #:guile-version guile-version))) ((= 0 pull-version) ;; Legacy 'guix pull': return the .scm and .go files as one -- cgit v1.2.3 From e3744779aabc4badd992f52ebaa085e6d68a2eeb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Nov 2018 15:48:04 +0100 Subject: self: Install shell completion files. * guix/self.scm (miscellaneous-files): New procedure. (whole-package): Remove #:substitute-keys, add #:miscellany. [build]: Remove code for SUBSTITUTE-KEYS and add code to copy MISCELLANY to OUTPUT. (compiled-guix): Adjust call to 'whole-package'. --- guix/self.scm | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 43223972c6..96fef44e78 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -405,11 +405,28 @@ (define object-directories (apply guix-main (command-line)))) #:guile guile)) +(define (miscellaneous-files source) + "Return data files taken from SOURCE." + (file-mapping "guix-misc" + `(("etc/bash_completion.d/guix" + ,(file-append* source "/etc/completion/bash/guix")) + ("etc/bash_completion.d/guix-daemon" + ,(file-append* source "/etc/completion/bash/guix-daemon")) + ("share/zsh/site-functions/_guix" + ,(file-append* source "/etc/completion/zsh/_guix")) + ("share/fish/vendor_completions.d/guix.fish" + ,(file-append* source "/etc/completion/fish/guix.fish")) + ("share/guix/hydra.gnu.org.pub" + ,(file-append* source + "/etc/substitutes/hydra.gnu.org.pub")) + ("share/guix/berlin.guixsd.org.pub" + ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub"))))) + (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) compiled-modules - info daemon substitute-keys + info daemon miscellany guile (command (guix-command modules #:dependencies dependencies @@ -424,6 +441,7 @@ (define* (whole-package name modules dependencies (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")) (symlink #$command (string-append #$output "/bin/guix")) @@ -432,13 +450,6 @@ (define* (whole-package name modules dependencies (symlink (string-append #$daemon "/bin/guix-daemon") (string-append #$output "/bin/guix-daemon"))) - (when #$substitute-keys - (mkdir-p (string-append #$output "/share/guix")) - (copy-recursively #$substitute-keys - (string-append #$output - "/share/guix") - #:log (%make-void-port "w"))) - (let ((modules (string-append #$output "/share/guile/site/" (effective-version))) @@ -450,6 +461,10 @@ (define* (whole-package name modules dependencies (string-append #$output "/share/info")))) + (when #$miscellany + (copy-recursively #$miscellany #$output + #:log (%make-void-port "w"))) + ;; Object files. (when #$compiled-modules (let ((modules (string-append #$output "/lib/guile/" @@ -675,8 +690,7 @@ (define (built-modules node-subset) 'guix-daemon) #:info (info-manual source) - #:substitute-keys (file-append* source - "etc/substitutes") + #:miscellany (miscellaneous-files source) #:guile-version guile-version))) ((= 0 pull-version) ;; Legacy 'guix pull': return the .scm and .go files as one -- cgit v1.2.3 From 9da4848632ea47bbd55ba1d8f8756d91961c44fe Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 6 Nov 2018 18:21:24 +0100 Subject: guix: Update to Bioconductor 3.8. * guix/import/cran.scm (%bioconductor-version): Update to 3.8. * guix/build-system/r.scm (bioconductor-uri): Update archive URL. --- guix/build-system/r.scm | 2 +- guix/import/cran.scm | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index d5f897932f..664515d0ee 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -53,7 +53,7 @@ (define (bioconductor-uri name version) (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.7/bioc/src/contrib/Archive/" + (string-append "https://bioconductor.org/packages/3.8/bioc/src/contrib/Archive/" name "_" version ".tar.gz"))) (define %r-build-system-modules diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 89c84f7037..8f2c10258a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -127,9 +127,9 @@ (define* (maybe-inputs package-inputs #:optional (type 'inputs)) (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.7. Bioconductor packages should be +;; The latest Bioconductor release is 3.8. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.7") +(define %bioconductor-version "3.8") (define %bioconductor-packages-list-url (string-append "https://bioconductor.org/packages/" -- cgit v1.2.3 From ec4c81fe32a90890a6190443248078ce7366503f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Oct 2018 23:47:59 +0200 Subject: pack: Move store database creation to a separate derivation. * guix/scripts/pack.scm (store-database): New procedure. (self-contained-tarball): Use it when LOCALSTATEDIR? is true. Remove 'schema' and add 'database'. [build]: Pass DATABASE to 'populate-single-profile-directory'. (squashfs-image): Remove #:deduplicate? parameter. [build]: Remove (gnu build install) and (guix config) from the imported modules. Remove 'with-extensions'. * gnu/build/install.scm (populate-single-profile-directory): Remove #:deduplicate?, #:register?, and #:schema; add #:database. Remove call to 'register-closure' and simply copy DATABASE instead. --- gnu/build/install.scm | 17 ++--- guix/scripts/pack.scm | 182 ++++++++++++++++++++++++++++++-------------------- 2 files changed, 115 insertions(+), 84 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 98c547f2e4..9f9a6aba0f 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -161,14 +161,13 @@ (define* (register-closure prefix closure (define* (populate-single-profile-directory directory #:key profile closure (profile-name "guix-profile") - deduplicate? - register? schema) + database) "Populate DIRECTORY with a store containing PROFILE, whose closure is given in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY is initialized to contain a single profile under /root pointing to PROFILE. -When REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the -contents of the store; DEDUPLICATE? determines whether to deduplicate files in -the store. + +When DATABASE is true, copy it to DIRECTORY/var/guix/db and create +DIRECTORY/var/guix/gcroots and friends. PROFILE-NAME is the name of the profile being created under /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\". @@ -189,11 +188,9 @@ (define (symlink* old new) ;; Populate the store. (populate-store (list closure) directory) - (when register? - (register-closure (canonicalize-path directory) closure - #:deduplicate? deduplicate? - #:schema schema) - + (when database + (install-file database (scope "/var/guix/db/")) + (chmod (scope "/var/guix/db/db.sqlite") #o644) (mkdir-p* "/var/guix/profiles") (mkdir-p* "/var/guix/gcroots") (symlink* "/var/guix/profiles" diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 83bfa4ce00..faeea68426 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -103,6 +103,47 @@ (define gcrypt-sqlite3&co (package-transitive-propagated-inputs package))) (list guile-gcrypt guile-sqlite3))) +(define (store-database items) + "Return a directory containing a store database where all of ITEMS and their +dependencies are registered." + (define schema + (local-file (search-path %load-path + "guix/store/schema.sql"))) + + + (define labels + (map (lambda (n) + (string-append "closure" (number->string n))) + (iota (length items)))) + + (define build + (with-extensions gcrypt-sqlite3&co + ;; XXX: Adding (gnu build install) just to work around + ;; : that way, (guix build store-copy) is + ;; copied last and the 'store-info-XXX' macros are correctly expanded. + (with-imported-modules (source-module-closure + '((guix build store-copy) + (guix store database) + (gnu build install))) + #~(begin + (use-modules (guix store database) + (guix build store-copy) + (srfi srfi-1)) + + (define (read-closure closure) + (call-with-input-file closure read-reference-graph)) + + (let ((items (append-map read-closure '#$labels))) + (register-items items + #:state-directory #$output + #:deduplicate? #f + #:reset-timestamps? #f + #:registration-time %epoch + #:schema #$schema)))))) + + (computed-file "store-database" build + #:options `(#:references-graphs ,(zip labels items)))) + (define* (self-contained-tarball name profile #:key target deduplicate? @@ -117,10 +158,10 @@ (define* (self-contained-tarball name profile SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define schema + (define database (and localstatedir? - (local-file (search-path %load-path - "guix/store/schema.sql")))) + (file-append (store-database (list profile)) + "/db/db.sqlite"))) (define build (with-imported-modules `(((guix config) => ,(make-config.scm)) @@ -181,9 +222,7 @@ (define tar-supports-sort? (populate-single-profile-directory %root #:profile #$profile #:closure "profile" - #:deduplicate? #f - #:register? #$localstatedir? - #:schema #$schema) + #:database #+database) ;; Create SYMLINKS. (for-each (cut evaluate-populate-directive <> %root) @@ -240,7 +279,6 @@ (define tar-supports-sort? (define* (squashfs-image name profile #:key target - deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -252,74 +290,70 @@ (define* (squashfs-image name profile SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." (define build - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - '((guix build utils) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-sqlite3&co - #~(begin - (use-modules (guix build utils) - (gnu build install) - (guix build store-copy) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - - (setenv "PATH" (string-append #$archiver "/bin")) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build store-copy)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + (guix build store-copy) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) - ;; We need an empty file in order to have a valid file argument when - ;; we reparent the root file system. Read on for why that's - ;; necessary. - (with-output-to-file ".empty" (lambda () (display ""))) - - ;; Create the squashfs image in several steps. - ;; Add all store items. Unfortunately mksquashfs throws away all - ;; ancestor directories and only keeps the basename. We fix this - ;; in the following invocations of mksquashfs. - (apply invoke "mksquashfs" - `(,@(map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - ,#$output - - ;; Do not perform duplicate checking because we - ;; don't have any dupes. - "-no-duplicates" - "-comp" - ,#+(compressor-name compressor))) - - ;; Here we reparent the store items. For each sub-directory of - ;; the store prefix we need one invocation of "mksquashfs". - (for-each (lambda (dir) - (apply invoke "mksquashfs" - `(".empty" - ,#$output - "-root-becomes" ,dir))) - (reverse (string-tokenize (%store-directory) - (char-set-complement (char-set #\/))))) - - ;; Add symlinks and mount points. - (apply invoke "mksquashfs" - `(".empty" - ,#$output - ;; Create SYMLINKS via pseudo file definitions. - ,@(append-map - (match-lambda - ((source '-> target) - (list "-p" - (string-join - ;; name s mode uid gid symlink - (list source - "s" "777" "0" "0" - (string-append #$profile "/" target)))))) - '#$symlinks) - - ;; Create empty mount points. - "-p" "/proc d 555 0 0" - "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0")))))) + (setenv "PATH" (string-append #$archiver "/bin")) + + ;; We need an empty file in order to have a valid file argument when + ;; we reparent the root file system. Read on for why that's + ;; necessary. + (with-output-to-file ".empty" (lambda () (display ""))) + + ;; Create the squashfs image in several steps. + ;; Add all store items. Unfortunately mksquashfs throws away all + ;; ancestor directories and only keeps the basename. We fix this + ;; in the following invocations of mksquashfs. + (apply invoke "mksquashfs" + `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + ,#$output + + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) + + ;; Here we reparent the store items. For each sub-directory of + ;; the store prefix we need one invocation of "mksquashfs". + (for-each (lambda (dir) + (apply invoke "mksquashfs" + `(".empty" + ,#$output + "-root-becomes" ,dir))) + (reverse (string-tokenize (%store-directory) + (char-set-complement (char-set #\/))))) + + ;; Add symlinks and mount points. + (apply invoke "mksquashfs" + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(append-map + (match-lambda + ((source '-> target) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (string-append #$profile "/" target)))))) + '#$symlinks) + + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0"))))) (gexp->derivation (string-append name (compressor-extension compressor) -- cgit v1.2.3 From b27ef1d46cfdc3c994b106241f99cd7142083d13 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Oct 2018 00:17:08 +0200 Subject: pack: Import (guix store database) only when '--localstatedir' is passed. This is another way to address , which was previously addressed in commit 19c924af4f3726688ca155a905ebf1cb9acdfca2. * gnu/build/install.scm (register-closure): Move to... * gnu/build/vm.scm (register-closure): ... here. New procedure. * guix/scripts/pack.scm (self-contained-tarball)[build]: Remove now unneeded 'with-extensions' form and custom (guix config) module. * tests/guix-pack.sh: Revert the strategy from commit 19c924af4f3726688ca155a905ebf1cb9acdfca2. * tests/pack.scm ("self-contained-tarball"): Likewise. --- gnu/build/install.scm | 18 ----- gnu/build/vm.scm | 19 ++++- guix/scripts/pack.scm | 211 +++++++++++++++++++++++++------------------------- tests/guix-pack.sh | 26 ++----- tests/pack.scm | 64 +++++++-------- 5 files changed, 159 insertions(+), 179 deletions(-) (limited to 'guix') diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 9f9a6aba0f..a31e1945d6 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -18,7 +18,6 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu build install) - #:use-module (guix store database) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -141,23 +140,6 @@ (define (populate-root-file-system system target) (try)) (apply throw args))))))) -(define* (register-closure prefix closure - #:key - (deduplicate? #t) (reset-timestamps? #t) - (schema (sql-schema))) - "Register CLOSURE in PREFIX, where PREFIX is the directory name of the -target store and CLOSURE is the name of a file containing a reference graph as -produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is -true, reset timestamps on store files and, if DEDUPLICATE? is true, -deduplicates files common to CLOSURE and the rest of PREFIX." - (let ((items (call-with-input-file closure read-reference-graph))) - (register-items items - #:prefix prefix - #:deduplicate? deduplicate? - #:reset-timestamps? reset-timestamps? - #:registration-time %epoch - #:schema schema))) - (define* (populate-single-profile-directory directory #:key profile closure (profile-name "guix-profile") diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 5579886264..746808515f 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -25,7 +25,7 @@ (define-module (gnu build vm) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (guix build syscalls) - #:use-module ((guix store database) #:select (reset-timestamps)) + #:use-module (guix store database) #:use-module (gnu build linux-boot) #:use-module (gnu build install) #:use-module (gnu system uuid) @@ -191,6 +191,23 @@ (define arch-specific-flags (mkdir output) (copy-recursively "xchg" output))))) +(define* (register-closure prefix closure + #:key + (deduplicate? #t) (reset-timestamps? #t) + (schema (sql-schema))) + "Register CLOSURE in PREFIX, where PREFIX is the directory name of the +target store and CLOSURE is the name of a file containing a reference graph as +produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is +true, reset timestamps on store files and, if DEDUPLICATE? is true, +deduplicates files common to CLOSURE and the rest of PREFIX." + (let ((items (call-with-input-file closure read-reference-graph))) + (register-items items + #:prefix prefix + #:deduplicate? deduplicate? + #:reset-timestamps? reset-timestamps? + #:registration-time %epoch + #:schema schema))) + ;;; ;;; Partitions. diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index faeea68426..3e6430bcce 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -164,113 +164,110 @@ (define database "/db/db.sqlite"))) (define build - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - `((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-sqlite3&co - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. For testing, we use the bootstrap tar, which is - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; Add 'tar' to the search path. - (setenv "PATH" #+(file-append archiver "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:database #+database) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - #+@(if (compressor-command compressor) - #~("-I" - (string-join - '#+(compressor-command compressor))) - #~()) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))))) + (with-imported-modules (source-module-closure + `((guix build utils) + (guix build union) + (gnu build install)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; . + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:database #+database) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + #+@(if (compressor-command compressor) + #~("-I" + (string-join + '#+(compressor-command compressor))) + #~()) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index cd721a60e9..8c1f556426 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -29,33 +29,21 @@ fi guix pack --version -# Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, 'guix pack' -# produces derivations that refer to guile-sqlite3 and libgcrypt. To make -# that relatively inexpensive, run the test in the user's global store if -# possible, on the grounds that binaries may already be there or can be built -# or downloaded inexpensively. - -NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`" -localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`" -GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket" -export NIX_STORE_DIR GUIX_DAEMON_SOCKET - -if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))' -then - exit 77 -fi +# Use --no-substitutes because we need to verify we can do this ourselves. +GUIX_BUILD_OPTIONS="--no-substitutes" +export GUIX_BUILD_OPTIONS # Build a tarball with no compression. -guix pack --compression=none guile-bootstrap +guix pack --compression=none --bootstrap guile-bootstrap # Build a tarball (with compression). Check that '-e' works as well. -out1="`guix pack guile-bootstrap`" -out2="`guix pack -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" +out1="`guix pack --bootstrap guile-bootstrap`" +out2="`guix pack --bootstrap -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" test -n "$out1" test "$out1" = "$out2" # Build a tarball with a symlink. -the_pack="`guix pack -S /opt/gnu/bin=bin guile-bootstrap`" +the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`" # Try to extract it. Note: we cannot test whether /opt/gnu/bin/guile itself # exists because /opt/gnu/bin may be an absolute symlink to a store item that diff --git a/tests/pack.scm b/tests/pack.scm index 4eb5be92ff..6bd18bdee2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -29,6 +29,9 @@ (define-module (test-pack) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-64)) +(define %store + (open-connection-for-tests)) + ;; Globally disable grafts because they can trigger early builds. (%graft? #f) @@ -48,40 +51,33 @@ (define %tar-bootstrap %bootstrap-coreutils&co) (test-begin "pack") -;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of -;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, -;; run it on the user's store, if it's available, on the grounds that these -;; dependencies may be already there, or we can get substitutes or build them -;; quite inexpensively; see . - -(with-external-store store - (unless store (test-skip 1)) - (test-assertm "self-contained-tarball" store - (mlet* %store-monad - ((profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) - (tarball (self-contained-tarball "pack" profile - #:symlinks '(("/bin/Guile" - -> "bin/guile")) - #:compressor %gzip-compressor - #:archiver %tar-bootstrap)) - (check (gexp->derivation - "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile")))))))) - (built-derivations (list check))))) +(unless (network-reachable?) (test-skip 1)) +(test-assertm "self-contained-tarball" %store + (mlet* %store-monad + ((profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (self-contained-tarball "pack" profile + #:symlinks '(("/bin/Guile" + -> "bin/guile")) + #:compressor %gzip-compressor + #:archiver %tar-bootstrap)) + (check (gexp->derivation + "check-tarball" + #~(let ((bin (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile")))))))) + (built-derivations (list check)))) (test-end) -- cgit v1.2.3 From f5a2fb1bfbb620a6ce23ac0e7e15132cae9207da Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 Nov 2018 21:53:07 +0100 Subject: pack: Docker backend now honors '--localstatedir'. * guix/docker.scm (build-docker-image): Add #:database parameter. Create /var/guix/db, /var/guix/profiles, etc. when DATABASE is true. * guix/scripts/pack.scm (docker-image): Export. Remove #:deduplicate? parameter. Define 'database' and pass it to 'docker-image'. * tests/pack.scm (test-assertm): Recompile the derivation of %BOOTSTRAP-GUILE. ("docker-image + localstatedir"): New test. --- guix/docker.scm | 16 +++++++++++++++- guix/scripts/pack.scm | 9 ++++++++- tests/pack.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 74 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index 0757d3356f..c19a24d45c 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -26,6 +26,7 @@ (define-module (guix docker) delete-file-recursively with-directory-excursion invoke)) + #:use-module (gnu build install) #:use-module (json) ;guile-json #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -108,11 +109,15 @@ (define* (build-docker-image image paths prefix (symlinks '()) (transformations '()) (system (utsname:machine (uname))) + database compressor (creation-time (current-time time-utc))) "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX must be a store path that is a prefix of any store paths in PATHS. +When DATABASE is true, copy it to /var/guix/db in the image and create +/var/guix/gcroots and friends. + SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be created in the image, where each TARGET is relative to PREFIX. TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to @@ -188,10 +193,15 @@ (define transformation-options source)))) symlinks) + (when database + ;; Initialize /var/guix, assuming PREFIX points to a profile. + (install-database-and-gc-roots "." database prefix)) + (apply invoke "tar" "-cf" "layer.tar" `(,@transformation-options ,@%tar-determinism-options ,@paths + ,@(if database '("var") '()) ,@(map symlink-source symlinks))) ;; It is possible for "/" to show up in the archive, especially when ;; applying transformations. For example, the transformation @@ -203,7 +213,11 @@ (define transformation-options (system* "tar" "--delete" "/" "-f" "layer.tar") (for-each delete-file-recursively (map (compose topmost-component symlink-source) - symlinks))) + symlinks)) + + ;; Delete /var/guix. + (when database + (delete-file-recursively "var"))) (with-output-to-file "config.json" (lambda () diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 3e6430bcce..09fc88988a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -52,6 +52,8 @@ (define-module (guix scripts pack) #:export (compressor? lookup-compressor self-contained-tarball + docker-image + guix-pack)) ;; Type of a compression tool. @@ -360,7 +362,6 @@ (define build (define* (docker-image name profile #:key target - deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -370,6 +371,11 @@ (define* (docker-image name profile with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it must a be a GNU triplet and it is used to derive the architecture metadata in the image." + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) + (define defmod 'define-module) ;trick Geiser (define build @@ -388,6 +394,7 @@ (define build (call-with-input-file "profile" read-reference-graph)) #$profile + #:database #+database #:system (or #$target (utsname:machine (uname))) #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) diff --git a/tests/pack.scm b/tests/pack.scm index 6bd18bdee2..bfff802d8a 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -22,6 +22,7 @@ (define-module (test-pack) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix profiles) + #:use-module (guix packages) #:use-module (guix monads) #:use-module (guix grafts) #:use-module (guix tests) @@ -37,8 +38,9 @@ (define %store (define-syntax-rule (test-assertm name store exp) (test-assert name - (run-with-store store exp - #:guile-for-build (%guile-for-build)))) + (let ((guile (package-derivation store %bootstrap-guile))) + (run-with-store store exp + #:guile-for-build guile)))) (define %gzip-compressor ;; Compressor that uses the bootstrap 'gzip'. @@ -79,6 +81,53 @@ (define %tar-bootstrap %bootstrap-coreutils&co) (readlink "bin/Guile")))))))) (built-derivations (list check)))) +;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of +;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, +;; run it on the user's store, if it's available, on the grounds that these +;; dependencies may be already there, or we can get substitutes or build them +;; quite inexpensively; see . + +(with-external-store store + (unless store (test-skip 1)) + (test-assertm "docker-image + localstatedir" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (docker-image "docker-pack" profile + #:symlinks '(("/bin/Guile" -> "bin/guile")) + #:localstatedir? #t)) + (check (gexp->derivation + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) + (mkdir "base") + (with-directory-excursion "base" + (invoke "tar" "xvf" #$tarball)) + + (match (find-files "base" "layer.tar") + ((layer) + (invoke "tar" "xvf" layer))) + + (when + (and (file-exists? (string-append bin "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + (string=? (string-append #$profile "/bin/guile") + (pk 'guilelink (readlink "bin/Guile")))) + (mkdir #$output))))))) + (built-derivations (list check))))) + (test-end) ;; Local Variables: -- cgit v1.2.3 From 598a6b87cc6636aee9dec57ae95922da0a6e31e8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Nov 2018 17:16:22 +0100 Subject: pack: Squashfs backend now honors '--localstatedir'. * guix/scripts/pack.scm (squashfs-image)[database]: New variable. [build]: Add (gnu build install) to the closure. Call 'install-database-and-gc-roots' when DATABASE is true, and invoke mksquashfs once more. * tests/pack.scm ("squashfs-image + localstatedir"): New test. --- guix/scripts/pack.scm | 19 +++++++++++++++++-- tests/pack.scm | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 09fc88988a..a86b95dd38 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -53,6 +53,7 @@ (define-module (guix scripts pack) lookup-compressor self-contained-tarball docker-image + squashfs-image guix-pack)) @@ -288,18 +289,27 @@ (define* (squashfs-image name profile SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) + (define build (with-imported-modules (source-module-closure '((guix build utils) - (guix build store-copy)) + (guix build store-copy) + (gnu build install)) #:select? not-config?) #~(begin (use-modules (guix build utils) (guix build store-copy) + (gnu build install) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) + (define database #+database) + (setenv "PATH" (string-append #$archiver "/bin")) ;; We need an empty file in order to have a valid file argument when @@ -352,7 +362,12 @@ (define build ;; Create empty mount points. "-p" "/proc d 555 0 0" "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0"))))) + "-p" "/dev d 555 0 0")) + + (when database + ;; Initialize /var/guix. + (install-database-and-gc-roots "var-etc" database #$profile) + (invoke "mksquashfs" "var-etc" #$output))))) (gexp->derivation (string-append name (compressor-extension compressor) diff --git a/tests/pack.scm b/tests/pack.scm index bfff802d8a..0c9e4ffa7f 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -28,6 +28,7 @@ (define-module (test-pack) #:use-module (guix tests) #:use-module (guix gexp) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages compression) #:select (squashfs-tools-next)) #:use-module (srfi srfi-64)) (define %store @@ -126,6 +127,41 @@ (define bin (string=? (string-append #$profile "/bin/guile") (pk 'guilelink (readlink "bin/Guile")))) (mkdir #$output))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "squashfs-image + localstatedir" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (image (squashfs-image "squashfs-pack" profile + #:symlinks '(("/bin" -> "bin")) + #:localstatedir? #t)) + (check (gexp->derivation + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$squashfs-tools-next "/bin")) + (invoke "unsquashfs" #$image) + (with-directory-excursion "squashfs-root" + (when (and (file-exists? (string-append bin + "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + (string=? (string-append #$profile "/bin") + (pk 'guilelink (readlink "bin")))) + (mkdir #$output)))))))) (built-derivations (list check))))) (test-end) -- cgit v1.2.3 From 72dc64f8f720268930eed448abfc15d2a0eca3cf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Nov 2018 22:05:32 +0100 Subject: store-copy: Canonicalize the mtime and permissions of the store copy. Fixes a bug whereby directories in the output of 'guix pack -f tarball' would not be read-only. * guix/build/store-copy.scm (reset-permissions): New procedure. (populate-store): Pass #:keep-mtime? #t to 'copy-recursively'. Call 'reset-permissions'. * tests/pack.scm ("self-contained-tarball"): In CHECK, define 'canonical?' and use it to check that every file has an mtime of 1 and is read-only. * tests/guix-pack.sh: Invoke "chmod -Rf +w" before "rm -rf" in trap. --- guix/build/store-copy.scm | 28 +++++++++++++++++++++++++++ tests/guix-pack.sh | 2 +- tests/pack.scm | 48 +++++++++++++++++++++++++++++++++++------------ 3 files changed, 65 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 64ade7885c..549aa4f28b 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -168,6 +168,28 @@ (define items (reduce + 0 (map file-size items))) +(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 @@ -197,7 +219,13 @@ (define (graph-from-file file) (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))))) diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 8c1f556426..a43f4d128f 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -49,7 +49,7 @@ the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`" # exists because /opt/gnu/bin may be an absolute symlink to a store item that # has been GC'd. test_directory="`mktemp -d`" -trap 'rm -rf "$test_directory"' EXIT +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT cd "$test_directory" tar -xf "$the_pack" test -L opt/gnu/bin diff --git a/tests/pack.scm b/tests/pack.scm index a9bc8948b9..40473a9fe9 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -68,18 +68,42 @@ (define %tar-bootstrap %bootstrap-coreutils&co) #:archiver %tar-bootstrap)) (check (gexp->derivation "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile")))))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define store + ;; The unpacked store. + (string-append "." (%store-directory) "/")) + + (define (canonical? file) + ;; Return #t if FILE is read-only and its mtime is 1. + (let ((st (lstat file))) + (or (not (string-prefix? store file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 + (stat:mode st))))))) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (file-exists? store) + (every canonical? + (find-files "." (const #t) + #:directories? #t)) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile"))))))))) (built-derivations (list check)))) ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of -- cgit v1.2.3