From b111bceecc4d85b6147f2b672049f6a479a8c69d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Mar 2017 21:51:27 +0100 Subject: download: Export '%x509-certificate-directory'. * guix/build/download.scm (%x509-certificate-directory): Export, as expected by (guix scripts pull) since commit 7e81d699de7a2c924a048175516fe1ac3820d8e6. --- guix/build/download.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 203338b527..e7a7afecd1 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Steve Sprang ;;; @@ -37,6 +37,7 @@ #:use-module (ice-9 format) #:export (open-socket-for-uri open-connection-for-uri + %x509-certificate-directory close-connection resolve-uri-reference maybe-expand-mirrors -- cgit v1.2.3 From 3b2dc9edcda19666623cc62dc3df2235b797f1b9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Mar 2017 11:19:21 +0100 Subject: upstream: Avoid '_' as a pattern variable in 'match'. * guix/upstream.scm (lookup-updater): Don't use '_' as a pattern variable. --- guix/upstream.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index 2334c4c0a6..a47a52be3f 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -131,7 +131,7 @@ correspond to the same version." "Return an updater among UPDATERS that matches PACKAGE, or #f if none of them matches." (any (match-lambda - (($ _ _ pred latest) + (($ name description pred latest) (and (pred package) latest))) updaters)) -- cgit v1.2.3 From 6b63c43e0661406bf9e8c4c54f517744fc2ffdb3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Mar 2017 15:11:03 +0100 Subject: pack: Add '--localstatedir' option. * guix/scripts/pack.scm (self-contained-tarball): Add #:localstatedir? parameter and honor it. (%options, show-help): Add '--localstatedir'. (guix-pack): Honor it. * gnu/build/install.scm (populate-single-profile-directory): Add #:register? parameter and honor it. * doc/guix.texi (Binary Installation): Use '--localstatedir' in example. (Invoking guix pack): Document it. --- Makefile.am | 2 +- doc/guix.texi | 15 ++++++++++++++- gnu/build/install.scm | 29 +++++++++++++++++------------ guix/scripts/pack.scm | 33 +++++++++++++++++++++++++-------- 4 files changed, 57 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 2684d66bf1..23171ae837 100644 --- a/Makefile.am +++ b/Makefile.am @@ -488,7 +488,7 @@ AM_DISTCHECK_CONFIGURE_FLAGS = \ guix-binary.%.tar.xz: $(AM_V_GEN)GUIX_PACKAGE_PATH= \ tarball=`$(top_builddir)/pre-inst-env guix pack -C xz \ - -s "$*" guix` ; \ + -s "$*" --localstatedir guix` ; \ cp "$$tarball" "$@.tmp" ; mv "$@.tmp" "$@" diff --git a/doc/guix.texi b/doc/guix.texi index f4cc207e7b..86fc86da61 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -535,7 +535,7 @@ make guix-binary.@var{system}.tar.xz ... which, in turn, runs: @example -guix pack -s @var{system} guix +guix pack -s @var{system} --localstatedir guix @end example @xref{Invoking guix pack}, for more info on this handy tool. @@ -2434,6 +2434,19 @@ the system type of the build host. @itemx -C @var{tool} Compress the resulting tarball using @var{tool}---one of @code{gzip}, @code{bzip2}, @code{xz}, or @code{lzip}. + +@item --localstatedir +Include the ``local state directory'', @file{/var/guix}, in the +resulting pack. + +@file{/var/guix} contains the store database (@pxref{The Store}) as well +as garbage-collector roots (@pxref{Invoking guix gc}). Providing it in +the pack means that the store is ``complete'' and manageable by Guix; +not providing it pack means that the store is ``dead'': items cannot be +added to it or removed from it after extraction of the pack. + +One use case for this is the Guix self-contained binary tarball +(@pxref{Binary Installation}). @end table In addition, @command{guix pack} supports all the common build options diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 5c2b35632d..11f107d63c 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -192,13 +192,16 @@ rest of STORE." (define* (populate-single-profile-directory directory #:key profile closure - deduplicate?) + deduplicate? + register?) "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. -DEDUPLICATE? determines whether to deduplicate files in the store. +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. -This is used to create the self-contained Guix tarball." +This is used to create the self-contained tarballs with 'guix pack'." (define (scope file) (string-append directory "/" file)) @@ -213,14 +216,16 @@ This is used to create the self-contained Guix tarball." ;; Populate the store. (populate-store (list closure) directory) - (register-closure (canonicalize-path directory) closure - #:deduplicate? deduplicate?) - - ;; XXX: 'guix-register' registers profiles as GC roots but the symlink - ;; target uses $TMPDIR. Fix that. - (delete-file (scope "/var/guix/gcroots/profiles")) - (symlink* "/var/guix/profiles" - "/var/guix/gcroots/profiles") + + (when register? + (register-closure (canonicalize-path directory) closure + #:deduplicate? deduplicate?) + + ;; XXX: 'guix-register' registers profiles as GC roots but the symlink + ;; target uses $TMPDIR. Fix that. + (delete-file (scope "/var/guix/gcroots/profiles")) + (symlink* "/var/guix/profiles" + "/var/guix/gcroots/profiles")) ;; Make root's profile, which makes it a GC root. (mkdir-p* %root-profile) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e8f3d800a8..138e2c5b77 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -69,10 +69,12 @@ found." (define* (self-contained-tarball name profile #:key deduplicate? - (compressor (first %compressors))) + (compressor (first %compressors)) + localstatedir?) "Return a self-contained tarball containing a store initialized with the -closure of PROFILE, a derivation. The tarball contains /gnu/store, /var/guix, -and PROFILE is available as /root/.guix-profile." +closure of PROFILE, a derivation. The tarball contains /gnu/store; if +LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db +with a properly initialized store database." (define build (with-imported-modules '((guix build utils) (guix build store-copy) @@ -85,7 +87,10 @@ and PROFILE is available as /root/.guix-profile." ;; We need Guix here for 'guix-register'. (setenv "PATH" - (string-append #$guix "/sbin:" #$tar "/bin:" + (string-append #$(if localstatedir? + (file-append guix "/sbin:") + "") + #$tar "/bin:" #$(compressor-package compressor) "/bin")) ;; Note: there is not much to gain here with deduplication and @@ -94,7 +99,8 @@ and PROFILE is available as /root/.guix-profile." (populate-single-profile-directory %root #:profile #$profile #:closure "profile" - #:deduplicate? #f) + #:deduplicate? #f + #:register? #$localstatedir?) ;; Create the tarball. Use GNU format so there's no file name ;; length limitation. @@ -119,7 +125,10 @@ and PROFILE is available as /root/.guix-profile." ;; extracting the archive. Do not include /root ;; because the root account might have a ;; different home directory. - "./var/guix" + #$@(if localstatedir? + '("./var/guix") + '()) + (string-append "." (%store-directory)))))))) (gexp->derivation (string-append name ".tar." @@ -163,6 +172,9 @@ and PROFILE is available as /root/.guix-profile." (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) + (option '("localstatedir") #f #f + (lambda (opt name arg result) + (alist-cons 'localstatedir? #t result))) (append %transformation-options %standard-build-options))) @@ -178,6 +190,8 @@ Create a bundle of PACKAGE.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) + (display (_ " + --localstatedir include /var/guix in the resulting pack")) (newline) (display (_ " -h, --help display this help and exit")) @@ -209,14 +223,17 @@ Create a bundle of PACKAGE.\n")) (specification->package+output spec)) list)) specs)) - (compressor (assoc-ref opts 'compressor))) + (compressor (assoc-ref opts 'compressor)) + (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store (run-with-store store (mlet* %store-monad ((profile (profile-derivation (packages->manifest packages))) (drv (self-contained-tarball "pack" profile #:compressor - compressor))) + compressor + #:localstatedir? + localstatedir?))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? -- cgit v1.2.3 From 5895ec8aa234ec9a4ce68ab8f94e795807630168 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Mar 2017 16:37:17 +0100 Subject: pack: Add '--symlink'. * guix/scripts/pack.scm (self-contained-tarball): Add #:symlinks parameter. [build](symlink->directives): New procedure (directives): New variable. Add call to 'evaluate-populate-directive'. Pass the directories among DIRECTIVES to 'tar'. (%default-options): Add 'symlinks'. (%options, show-help): Add '--symlink'. (guix-pack): Honor it. * gnu/build/install.scm (evaluate-populate-directive): Export. * doc/guix.texi (Invoking guix pack): Document it. --- doc/guix.texi | 24 +++++++++++ gnu/build/install.scm | 1 + guix/scripts/pack.scm | 107 +++++++++++++++++++++++++++++++++++++------------- 3 files changed, 104 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 86fc86da61..82298e677d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2422,6 +2422,18 @@ same as would be created by @command{guix package -i}. It is this mechanism that is used to create Guix's own standalone binary tarball (@pxref{Binary Installation}). +Users of this pack would have to run +@file{/gnu/store/@dots{}-profile/bin/guile} to run Guile, which you may +find inconvenient. To work around it, you can create, say, a +@file{/opt/gnu/bin} symlink to the profile: + +@example +guix pack -S /opt/gnu/bin=bin guile emacs geiser +@end example + +@noindent +That way, users can happily type @file{/opt/gnu/bin/guile} and enjoy. + Several command-line options allow you to customize your pack: @table @code @@ -2435,6 +2447,18 @@ the system type of the build host. Compress the resulting tarball using @var{tool}---one of @code{gzip}, @code{bzip2}, @code{xz}, or @code{lzip}. +@item --symlink=@var{spec} +@itemx -S @var{spec} +Add the symlinks specified by @var{spec} to the pack. This option can +appear several times. + +@var{spec} has the form @code{@var{source}=@var{target}}, where +@var{source} is the symlink that will be created and @var{target} is the +symlink target. + +For instance, @code{-S /opt/gnu/bin=bin} creates a @file{/opt/gnu/bin} +symlink pointing to the @file{bin} sub-directory of the profile. + @item --localstatedir Include the ``local state directory'', @file{/var/guix}, in the resulting pack. diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 11f107d63c..5cb6055a0c 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 match) #:export (install-grub install-grub-config + evaluate-populate-directive populate-root-file-system reset-timestamps register-closure diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 138e2c5b77..7a0e54d4cd 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -70,21 +70,41 @@ found." (define* (self-contained-tarball name profile #:key deduplicate? (compressor (first %compressors)) - localstatedir?) + localstatedir? + (symlinks '())) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db -with a properly initialized store database." +with a properly initialized store database. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." (define build (with-imported-modules '((guix build utils) (guix build store-copy) (gnu build install)) #~(begin (use-modules (guix build utils) - (gnu build install)) + (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))) + `((directory ,(dirname source)) + (,source -> ,target)))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + ;; We need Guix here for 'guix-register'. (setenv "PATH" (string-append #$(if localstatedir? @@ -102,34 +122,46 @@ with a properly initialized store database." #:deduplicate? #f #:register? #$localstatedir?) + ;; 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 - (zero? (system* "tar" #$(compressor-tar-option 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.) - "--sort=name" - "--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)))))))) + (exit + (zero? (apply system* "tar" #$(compressor-tar-option 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.) + "--sort=name" + "--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)) + (_ #f)) + directives))))))))) (gexp->derivation (string-append name ".tar." (compressor-extension compressor)) @@ -149,6 +181,7 @@ with a properly initialized store database." (graft? . #t) (max-silent-time . 3600) (verbosity . 0) + (symlinks . ()) (compressor . ,(first %compressors)))) (define %options @@ -172,6 +205,19 @@ with a properly initialized store database." (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) + (option '(#\S "symlink") #t #f + (lambda (opt name arg result) + (match (string-tokenize arg + (char-set-complement + (char-set #\=))) + ((source target) + (let ((symlinks (assoc-ref result 'symlinks))) + (alist-cons 'symlinks + `((,source -> ,target) ,@symlinks) + (alist-delete 'symlinks result eq?)))) + (x + (leave (_ "~a: invalid symlink specification~%") + arg))))) (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) @@ -190,6 +236,8 @@ Create a bundle of PACKAGE.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " -C, --compression=TOOL compress using TOOL--e.g., \"lzip\"")) + (display (_ " + -S, --symlink=SPEC create symlinks to the profile according to SPEC")) (display (_ " --localstatedir include /var/guix in the resulting pack")) (newline) @@ -224,6 +272,7 @@ Create a bundle of PACKAGE.\n")) list)) specs)) (compressor (assoc-ref opts 'compressor)) + (symlinks (assoc-ref opts 'symlinks)) (localstatedir? (assoc-ref opts 'localstatedir?))) (with-store store (run-with-store store @@ -232,6 +281,8 @@ Create a bundle of PACKAGE.\n")) (drv (self-contained-tarball "pack" profile #:compressor compressor + #:symlinks + symlinks #:localstatedir? localstatedir?))) (mbegin %store-monad -- cgit v1.2.3 From 36f213fb704b96856d037df26e8e125aeb08edf2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Mar 2017 21:31:10 +0100 Subject: pack: Use maximum compression; use '-n' for gzip. * guix/scripts/pack.scm ()[tar-option]: Remove. [command]: New field. (%compressors): Provide complete commands. Use '-9' or equivalent for each compressor; use '-n' for gzip. (self-contained-tarball)[build]: Adjust accordingly. --- guix/scripts/pack.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7a0e54d4cd..c3d85c568c 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -43,20 +43,19 @@ ;; Type of a compression tool. (define-record-type - (compressor name package extension tar-option) + (compressor name package extension command) compressor? (name compressor-name) ;string (e.g., "gzip") (package compressor-package) ;package (extension compressor-extension) ;string (e.g., "lz") - (tar-option compressor-tar-option)) ;string (e.g., "--lzip") + (command compressor-command)) ;list (e.g., '("gzip" "-9n")) (define %compressors ;; Available compression tools. - ;; FIXME: Use '--no-name' for gzip. - (list (compressor "gzip" gzip "gz" "--gzip") - (compressor "lzip" lzip "lz" "--lzip") - (compressor "xz" xz "xz" "--xz") - (compressor "bzip2" bzip2 "bz2" "--bzip2"))) + (list (compressor "gzip" gzip "gz" '("gzip" "-9n")) + (compressor "lzip" lzip "lz" '("lzip" "-9")) + (compressor "xz" xz "xz" '("xz" "-e")) + (compressor "bzip2" bzip2 "bz2" '("bzip2" "-9")))) (define (lookup-compressor name) "Return the compressor object called NAME. Error out if it could not be @@ -130,7 +129,8 @@ added to the pack." ;; length limitation. (with-directory-excursion %root (exit - (zero? (apply system* "tar" #$(compressor-tar-option compressor) + (zero? (apply system* "tar" + "-I" #$(string-join (compressor-command compressor)) "--format=gnu" ;; Avoid non-determinism in the archive. Use -- cgit v1.2.3 From 850edd77f92c1f40a1593f3505ff82fdd8719bad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Mar 2017 22:43:10 +0100 Subject: pack: Add unit test. * guix/scripts/pack.scm (self-contained-tarball): Add #:tar option. [build](tar-supports-sort?): New variable. Use it. * tests/pack.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 1 + guix/scripts/pack.scm | 13 +++++++-- tests/pack.scm | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 91 insertions(+), 2 deletions(-) create mode 100644 tests/pack.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 23171ae837..dea70de00f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -297,6 +297,7 @@ SCM_TESTS = \ tests/services.scm \ tests/scripts-build.scm \ tests/containers.scm \ + tests/pack.scm \ tests/import-utils.scm if HAVE_GUILE_JSON diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c3d85c568c..067b1227e0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -70,7 +70,8 @@ found." #:key deduplicate? (compressor (first %compressors)) localstatedir? - (symlinks '())) + (symlinks '()) + (tar tar)) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -104,6 +105,14 @@ added to the pack." ;; 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 #+tar "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + ;; We need Guix here for 'guix-register'. (setenv "PATH" (string-append #$(if localstatedir? @@ -137,7 +146,7 @@ added to the pack." ;; mtime = 1, not zero, because that is what the ;; daemon does for files in the store (see the ;; 'mtimeStore' constant in local-store.cc.) - "--sort=name" + (if tar-supports-sort? "--sort=name" "--mtime=@1") "--mtime=@1" ;for files in /var/guix "--owner=root:0" "--group=root:0" diff --git a/tests/pack.scm b/tests/pack.scm new file mode 100644 index 0000000000..de9ef8e6ab --- /dev/null +++ b/tests/pack.scm @@ -0,0 +1,79 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-pack) + #:use-module (guix scripts pack) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix profiles) + #:use-module (guix monads) + #:use-module (guix grafts) + #:use-module (guix tests) + #:use-module (guix gexp) + #: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) + +(define-syntax-rule (test-assertm name exp) + (test-assert name + (run-with-store %store exp + #:guile-for-build (%guile-for-build)))) + +(define %gzip-compressor + ;; Compressor that uses the bootstrap 'gzip'. + ((@ (guix scripts pack) compressor) "gzip" + %bootstrap-coreutils&co "gz" '("gzip" "-6n"))) + +(define %tar-bootstrap %bootstrap-coreutils&co) + + +(test-begin "pack") + +(test-assertm "self-contained-tarball" + (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 + #:tar %tar-bootstrap)) + (check (gexp->derivation + "check-tarball" + #~(let ((guile (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append guile "/guile")) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink guile)) + (string=? (string-append (string-drop guile 1) + "/guile") + (readlink "bin/Guile")))))))) + (built-derivations (list check)))) + +(test-end) -- cgit v1.2.3 From 81a0f1cdf12e7bcc34c1203f034a323fa8f52cf5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Mar 2017 10:40:51 +0100 Subject: zlib: Don't rely on EBADF being ignored by 'fport_close'. In 2.2, 'fport_close' no longer swallows EBADF and instead raises a 'system-error' for this. This commit adjusts for 2.2. * guix/zlib.scm (close-procedure): Remove. (make-gzip-input-port): Use 'port->fdes' instead of 'fileno'. Use 'gzclose' instead of 'close-procedure'. (make-gzip-output-port): Likewise. * tests/zlib.scm ("compression/decompression pipe"): Don't check whether PARENT is closed using 'port-closed?'. Instead, use 'seek' on the underlying FD and check for EBADF. --- guix/zlib.scm | 29 ++++++++++------------------- tests/zlib.scm | 11 ++++++++++- 2 files changed, 20 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/zlib.scm b/guix/zlib.scm index 74420129f6..3d830ef84e 100644 --- a/guix/zlib.scm +++ b/guix/zlib.scm @@ -149,21 +149,6 @@ the number of uncompressed bytes written, a strictly positive integer." ;; Z_DEFAULT_COMPRESSION. -1) -(define (close-procedure gzfile port) - "Return a procedure that closes GZFILE, ensuring its underlying PORT is -closed even if closing GZFILE triggers an exception." - (lambda () - (catch 'zlib-error - (lambda () - ;; 'gzclose' closes the underlying file descriptor. 'close-port' - ;; calls close(2), gets EBADF, which is ignores. - (gzclose gzfile) - (close-port port)) - (lambda args - ;; Make sure PORT is closed despite the zlib error. - (close-port port) - (apply throw args))))) - (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) "Return an input port that decompresses data read from PORT, a file port. PORT is automatically closed when the resulting port is closed. BUFFER-SIZE @@ -173,7 +158,11 @@ buffered input, which would be lost (and is lost anyway)." (define gzfile (match (drain-input port) ("" ;PORT's buffer is empty - (gzdopen (fileno port) "r")) + ;; Since 'gzclose' will eventually close the file descriptor beneath + ;; PORT, we increase PORT's revealed count and never call 'close-port' + ;; on PORT since we would get EBADF if 'gzclose' already closed it (on + ;; 2.0 EBADF is swallowed by 'fport_close' but on 2.2 it is raised). + (gzdopen (port->fdes port) "r")) (_ ;; This is unrecoverable but it's better than having the buffered input ;; be lost, leading to unclear end-of-file or corrupt-data errors down @@ -188,7 +177,8 @@ buffered input, which would be lost (and is lost anyway)." (gzbuffer! gzfile buffer-size)) (make-custom-binary-input-port "gzip-input" read! #f #f - (close-procedure gzfile port))) + (lambda () + (gzclose gzfile)))) (define* (make-gzip-output-port port #:key @@ -200,7 +190,7 @@ port is closed." (define gzfile (begin (force-output port) ;empty PORT's buffer - (gzdopen (fileno port) + (gzdopen (port->fdes port) (string-append "w" (number->string level))))) (define (write! bv start count) @@ -210,7 +200,8 @@ port is closed." (gzbuffer! gzfile buffer-size)) (make-custom-binary-output-port "gzip-output" write! #f #f - (close-procedure gzfile port))) + (lambda () + (gzclose gzfile)))) (define* (call-with-gzip-input-port port proc #:key (buffer-size %default-buffer-size)) diff --git a/tests/zlib.scm b/tests/zlib.scm index 5455240a71..f71609b7c5 100644 --- a/tests/zlib.scm +++ b/tests/zlib.scm @@ -57,7 +57,16 @@ (match (waitpid pid) ((_ . status) (and (zero? status) - (port-closed? parent) + + ;; PORT itself isn't closed but its underlying file + ;; descriptor must have been closed by 'gzclose'. + (catch 'system-error + (lambda () + (seek (fileno parent) 0 SEEK_CUR) + #f) + (lambda args + (= EBADF (system-error-errno args)))) + (bytevector=? received data)))))))))))) (test-end) -- cgit v1.2.3 From 70dfdd501af46b0db138f3e289523e2d43c8e76d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Mar 2017 13:41:18 +0100 Subject: syscalls: Adjust 'clone' to Guile 2.2. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Before that, something like: (call-with-container (lambda () (match (primitive-fork) …))) would hang in 'primitive-fork' as the child process (the one started in the container) would try to pthread_join the finalization thread in 'stop_finalization_thread' in libguile, not knowing that this thread is nonexistent. * guix/build/syscalls.scm (%set-automatic-finalization-enabled?!): New procedure. (without-automatic-finalization): New macro. (clone): Wrap PROC call in 'without-automatic-finalization'. --- guix/build/syscalls.scm | 45 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 58c23f2844..5aae1530f4 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -656,6 +656,36 @@ mounted at FILE." (define CLONE_NEWPID #x20000000) (define CLONE_NEWNET #x40000000) +(cond-expand + (guile-2.2 + (define %set-automatic-finalization-enabled?! + (let ((proc (pointer->procedure int + (dynamic-func + "scm_set_automatic_finalization_enabled" + (dynamic-link)) + (list int)))) + (lambda (enabled?) + "Switch on or off automatic finalization in a separate thread. +Turning finalization off shuts down the finalization thread as a side effect." + (->bool (proc (if enabled? 1 0)))))) + + (define-syntax-rule (without-automatic-finalization exp) + "Turn off automatic finalization within the dynamic extent of EXP." + (let ((enabled? #t)) + (dynamic-wind + (lambda () + (set! enabled? (%set-automatic-finalization-enabled?! #f))) + (lambda () + exp) + (lambda () + (%set-automatic-finalization-enabled?! enabled?)))))) + + (else + (define-syntax-rule (without-automatic-finalization exp) + ;; Nothing to do here: Guile 2.0 does not have a separate finalization + ;; thread. + exp))) + ;; The libc interface to sys_clone is not useful for Scheme programs, so the ;; low-level system call is wrapped instead. The 'syscall' function is ;; declared in as a variadic function; in practice, it expects 6 @@ -678,10 +708,17 @@ mounted at FILE." Unlike the fork system call, clone accepts FLAGS that specify which resources are shared between the parent and child processes." (let-values (((ret err) - (proc syscall-id flags - %null-pointer ;child stack - %null-pointer %null-pointer ;ptid & ctid - %null-pointer))) ;unused + ;; Guile 2.2 runs a finalization thread. 'primitive-fork' + ;; takes care of shutting it down before forking, and we + ;; must do the same here. Failing to do that, if the + ;; child process calls 'primitive-fork', it will hang + ;; while trying to pthread_join the finalization thread + ;; since that thread does not exist. + (without-automatic-finalization + (proc syscall-id flags + %null-pointer ;child stack + %null-pointer %null-pointer ;ptid & ctid + %null-pointer)))) ;unused (if (= ret -1) (throw 'system-error "clone" "~d: ~A" (list flags (strerror err)) -- cgit v1.2.3