From 932d1600564cbf359a6ccd1086b968a934bef8e5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Oct 2018 15:45:45 +0200 Subject: gexp: 'gexp-modules' now consistently deletes duplicates. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Clément Lassieur . * guix/gexp.scm (gexp-attribute): Add 'equal?' optional parameter; pass it to 'delete-duplicates'. (gexp-modules)[module=?]: New procedure. Pass it to 'gexp-attribute'. * tests/gexp.scm ("gexp-modules deletes duplicates"): New test. --- tests/gexp.scm | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'tests') diff --git a/tests/gexp.scm b/tests/gexp.scm index 813ea2ff6f..467370f8cb 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -680,6 +680,22 @@ #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) +(test-assert "gexp-modules deletes duplicates" ; + (let ((make-file (lambda () + ;; Use 'eval' to make sure we get an object that's not + ;; 'eq?' nor 'equal?' due to the closures it embeds. + (eval '(scheme-file "bar.scm" #~(define-module (bar))) + (current-module))))) + (define result + ((@@ (guix gexp) gexp-modules) + (with-imported-modules `(((bar) => ,(make-file)) + ((bar) => ,(make-file)) + (foo) (foo)) + #~+))) + + (match result + (((('bar) '=> (? scheme-file?)) ('foo)) #t)))) + (test-equal "gexp-modules and literal Scheme object" '() (gexp-modules #t)) -- cgit v1.2.3 From ec397b312f901da59d9a2e1cffb26bf31507e61f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Oct 2018 18:10:26 +0200 Subject: tests: Fix typo. This is a followup to 19c924af4f3726688ca155a905ebf1cb9acdfca2. * tests/pack.scm: Fix typo in 'test-skip'. --- tests/pack.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index 7f867894c2..4eb5be92ff 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -55,7 +55,7 @@ ;; quite inexpensively; see . (with-external-store store - (unless store (tests-skip 1)) + (unless store (test-skip 1)) (test-assertm "self-contained-tarball" store (mlet* %store-monad ((profile (profile-derivation (packages->manifest -- cgit v1.2.3 From 63eb2b899be7ac857454442e09d0ebd23fe4f871 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 26 Oct 2018 11:20:08 +0200 Subject: Add 'guix processes'. * guix/scripts/processes.scm, tests/processes.scm: New files. * Makefile.am (MODULES): Add the former. (SCM_TESTS): Add the latter. * po/guix/POTFILES.in: Add guix/scripts/processes.scm. * doc/guix.texi (Invoking guix processes): New node. (Invoking guix-daemon): Reference it. --- Makefile.am | 2 + doc/guix.texi | 63 +++++++++++++ guix/scripts/processes.scm | 223 +++++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + tests/processes.scm | 86 +++++++++++++++++ 5 files changed, 375 insertions(+) create mode 100644 guix/scripts/processes.scm create mode 100644 tests/processes.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 1acf0b12d0..8c3df8f396 100644 --- a/Makefile.am +++ b/Makefile.am @@ -201,6 +201,7 @@ MODULES = \ guix/scripts/hash.scm \ guix/scripts/pack.scm \ guix/scripts/pull.scm \ + guix/scripts/processes.scm \ guix/scripts/substitute.scm \ guix/scripts/authenticate.scm \ guix/scripts/refresh.scm \ @@ -343,6 +344,7 @@ SCM_TESTS = \ tests/ui.scm \ tests/status.scm \ tests/records.scm \ + tests/processes.scm \ tests/upstream.scm \ tests/combinators.scm \ tests/discovery.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 87579d414d..b41af61f12 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -194,6 +194,7 @@ Utilities * Invoking guix copy:: Copying to and from a remote store. * Invoking guix container:: Process isolation. * Invoking guix weather:: Assessing substitute availability. +* Invoking guix processes:: Listing client processes. Invoking @command{guix build} @@ -1239,6 +1240,12 @@ The build directory is automatically deleted upon completion, unless the build failed and the client specified @option{--keep-failed} (@pxref{Invoking guix build, @option{--keep-failed}}). +The daemon listens for connections and spawns one sub-process for each session +started by a client (one of the @command{guix} sub-commands.) The +@command{guix processes} command allows you to get an overview of the activity +on your system by viewing each of the active sessions and clients. +@xref{Invoking guix processes}, for more information. + The following command-line options are supported: @table @code @@ -6052,6 +6059,7 @@ the Scheme programming interface of Guix in a convenient way. * Invoking guix copy:: Copying to and from a remote store. * Invoking guix container:: Process isolation. * Invoking guix weather:: Assessing substitute availability. +* Invoking guix processes:: Listing client processes. @end menu @node Invoking guix build @@ -8752,6 +8760,61 @@ with the @code{-m} option of @command{guix package} (@pxref{Invoking guix package}). @end table +@node Invoking guix processes +@section Invoking @command{guix processes} + +The @command{guix processes} command can be useful to developers and system +administrators, especially on multi-user machines and on build farms: it lists +the current sessions (connections to the daemon), as well as information about +the processes involved@footnote{Remote sessions, when @command{guix-daemon} is +started with @option{--listen} specifying a TCP endpoint, are @emph{not} +listed.}. Here's an example of the information it returns: + +@example +$ sudo guix processes +SessionPID: 19002 +ClientPID: 19090 +ClientCommand: guix environment --ad-hoc python + +SessionPID: 19402 +ClientPID: 19367 +ClientCommand: guix publish -u guix-publish -p 3000 -C 9 @dots{} + +SessionPID: 19444 +ClientPID: 19419 +ClientCommand: cuirass --cache-directory /var/cache/cuirass @dots{} +LockHeld: /gnu/store/@dots{}-perl-ipc-cmd-0.96.lock +LockHeld: /gnu/store/@dots{}-python-six-bootstrap-1.11.0.lock +LockHeld: /gnu/store/@dots{}-libjpeg-turbo-2.0.0.lock +ChildProcess: 20495: guix offload x86_64-linux 7200 1 28800 +ChildProcess: 27733: guix offload x86_64-linux 7200 1 28800 +ChildProcess: 27793: guix offload x86_64-linux 7200 1 28800 +@end example + +In this example we see that @command{guix-daemon} has three clients: +@command{guix environment}, @command{guix publish}, and the Cuirass continuous +integration tool; their process identifier (PID) is given by the +@code{ClientPID} field. The @code{SessionPID} field gives the PID of the +@command{guix-daemon} sub-process of this particular session. + +The @code{LockHeld} fields show which store items are currently locked by this +session, which corresponds to store items being built or substituted (the +@code{LockHeld} field is not displayed when @command{guix processes} is not +running as root.) Last, by looking at the @code{ChildProcess} field, we +understand that these three builds are being offloaded (@pxref{Daemon Offload +Setup}). + +The output is in Recutils format so we can use the handy @command{recsel} +command to select sessions of interest (@pxref{Selection Expressions,,, +recutils, GNU recutils manual}). As an example, the command shows the command +line and PID of the client that triggered the build of a Perl package: + +@example +$ sudo guix processes | \ + recsel -p ClientPID,ClientCommand -e 'LockHeld ~ "perl"' +ClientPID: 19419 +ClientCommand: cuirass --cache-directory /var/cache/cuirass @dots{} +@end example @c ********************************************************************* @node GNU Distribution diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm new file mode 100644 index 0000000000..6a2f603599 --- /dev/null +++ b/guix/scripts/processes.scm @@ -0,0 +1,223 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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 (guix scripts processes) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-37) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (process? + process-id + process-parent-id + process-command + processes + + daemon-session? + daemon-session-process + daemon-session-client + daemon-session-children + daemon-session-locks-held + daemon-sessions + + guix-processes)) + +;; Process as can be found in /proc on GNU/Linux. +(define-record-type + (process id parent command) + process? + (id process-id) ;integer + (parent process-parent-id) ;integer | #f + (command process-command)) ;list of strings + +(define (write-process process port) + (format port "#" (process-id process))) + +(set-record-type-printer! write-process) + +(define (read-status-ppid port) + "Read the PPID from PORT, an input port on a /proc/PID/status file. Return +#f for PID 1 and kernel pseudo-processes." + (let loop () + (match (read-line port) + ((? eof-object?) #f) + (line + (if (string-prefix? "PPid:" line) + (string->number (string-trim-both (string-drop line 5))) + (loop)))))) + +(define %not-nul + (char-set-complement (char-set #\nul))) + +(define (read-command-line port) + "Read the zero-split command line from PORT, a /proc/PID/cmdline file, and +return it as a list." + (string-tokenize (read-string port) %not-nul)) + +(define (processes) + "Return a list of process records representing the currently alive +processes." + ;; This assumes a Linux-compatible /proc file system. There exists one for + ;; GNU/Hurd. + (filter-map (lambda (pid) + ;; There's a TOCTTOU race here. If we get ENOENT, simply + ;; ignore PID. + (catch 'system-error + (lambda () + (define ppid + (call-with-input-file (string-append "/proc/" pid "/status") + read-status-ppid)) + (define command + (call-with-input-file (string-append "/proc/" pid "/cmdline") + read-command-line)) + (process (string->number pid) ppid command)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + (scandir "/proc" string->number))) + +(define (process-open-files process) + "Return the list of files currently open by PROCESS." + (let ((directory (string-append "/proc/" + (number->string (process-id process)) + "/fd"))) + (map (lambda (fd) + (readlink (string-append directory "/" fd))) + (or (scandir directory string->number) '())))) + +;; Daemon session. +(define-record-type + (daemon-session process client children locks) + daemon-session? + (process daemon-session-process) ; + (client daemon-session-client) ; + (children daemon-session-children) ;list of + (locks daemon-session-locks-held)) ;list of strings + +(define (daemon-sessions) + "Return two values: the list of denoting the currently +active sessions, and the master 'guix-daemon' process." + (define (lock-file? file) + (and (string-prefix? (%store-prefix) file) + (string-suffix? ".lock" file))) + + (let* ((processes (processes)) + (daemons (filter (lambda (process) + (match (process-command process) + ((argv0 _ ...) + (string=? (basename argv0) "guix-daemon")) + (_ #f))) + processes)) + (children (filter (lambda (process) + (match (process-command process) + ((argv0 (= string->number argv1) _ ...) + (integer? argv1)) + (_ #f))) + daemons)) + (master (remove (lambda (process) + (memq process children)) + daemons))) + (define (lookup-process pid) + (find (lambda (process) + (and (process-id process) + (= pid (process-id process)))) + processes)) + + (define (lookup-children pid) + (filter (lambda (process) + (and (process-parent-id process) + (= pid (process-parent-id process)))) + processes)) + + (values (map (lambda (process) + (match (process-command process) + ((argv0 (= string->number client) _ ...) + (let ((files (process-open-files process))) + (daemon-session process + (lookup-process client) + (lookup-children (process-id process)) + (filter lock-file? files)))))) + children) + master))) + +(define (daemon-session->recutils session port) + "Display SESSION information in recutils format on PORT." + (format port "SessionPID: ~a~%" + (process-id (daemon-session-process session))) + (format port "ClientPID: ~a~%" + (process-id (daemon-session-client session))) + (format port "ClientCommand:~{ ~a~}~%" + (process-command (daemon-session-client session))) + (for-each (lambda (lock) + (format port "LockHeld: ~a~%" lock)) + (daemon-session-locks-held session)) + (for-each (lambda (process) + (format port "ChildProcess: ~a:~{ ~a~}~%" + (process-id process) + (process-command process))) + (daemon-session-children session))) + + +;;; +;;; Options. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix processes"))))) + +(define (show-help) + (display (G_ "Usage: guix processes +List the current Guix sessions and their processes.")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-processes . args) + (define options + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + cons + '())) + + (for-each (lambda (session) + (daemon-session->recutils session (current-output-port)) + (newline)) + (daemon-sessions))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 2e37a19407..74c223b283 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -32,6 +32,7 @@ guix/scripts/copy.scm guix/scripts/pack.scm guix/scripts/weather.scm guix/scripts/describe.scm +guix/scripts/processes.scm guix/gnu-maintenance.scm guix/scripts/container.scm guix/scripts/container/exec.scm diff --git a/tests/processes.scm b/tests/processes.scm new file mode 100644 index 0000000000..40454bcbc7 --- /dev/null +++ b/tests/processes.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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-processes) + #:use-module (guix scripts processes) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (gnu packages bootstrap) + #:use-module (guix tests) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads)) + +(test-begin "processes") + +(test-assert "not a client" + (not (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions)))) + +(test-assert "client" + (with-store store + (let* ((session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (daemon (daemon-session-process session))) + (and (kill (process-id daemon) 0) + (string-suffix? "guix-daemon" (first (process-command daemon))))))) + +(test-assert "client + lock" + (with-store store + (call-with-temporary-directory + (lambda (directory) + (let* ((token1 (string-append directory "/token1")) + (token2 (string-append directory "/token2")) + (exp #~(begin #$(random-text) + (mkdir #$token1) + (let loop () + (unless (file-exists? #$token2) + (sleep 1) + (loop))) + (mkdir #$output))) + (guile (package-derivation store %bootstrap-guile)) + (drv (run-with-store store + (gexp->derivation "foo" exp + #:guile-for-build guile))) + (thread (call-with-new-thread + (lambda () + (build-derivations store (list drv))))) + (_ (let loop () + (unless (file-exists? token1) + (usleep 200) + (loop)))) + (session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (locks (daemon-session-locks-held (pk 'session session)))) + (call-with-output-file token2 (const #t)) + (equal? (list (string-append (derivation->output-path drv) ".lock")) + locks)))))) + +(test-end "processes") -- 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 'tests') 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 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM." (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 @@ #: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 @@ the #:references-graphs parameter of 'derivation'." (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 @@ added to the pack." "/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 @@ #: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 @@ (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 'tests') 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 @@ 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 @@ return \"a\"." (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 @@ SRFI-19 time-utc object, as the creation time in metadata." 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 @@ SRFI-19 time-utc object, as the creation time in metadata." (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 @@ #:export (compressor? lookup-compressor self-contained-tarball + docker-image + guix-pack)) ;; Type of a compression tool. @@ -360,7 +362,6 @@ added to the pack." (define* (docker-image name profile #:key target - deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -370,6 +371,11 @@ image is a tarball conforming to the Docker Image Specification, compressed 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 @@ the image." (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 @@ #: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-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 @@ (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 'tests') 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 @@ lookup-compressor self-contained-tarball docker-image + squashfs-image guix-pack)) @@ -288,18 +289,27 @@ points for virtual file systems (like procfs), and optional symlinks. 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 @@ added to the pack." ;; 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 @@ #: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 @@ (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 1ff53787dbd4b1846ae523aef86ada3996de5e6d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Nov 2018 17:34:16 +0100 Subject: pack: Add test for 'self-contained-tarball' with localstatedir. * tests/pack.scm ("self-contained-tarball + localstatedir"): New test. --- tests/pack.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index 0c9e4ffa7f..a9bc8948b9 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -89,6 +89,29 @@ ;; quite inexpensively; see . (with-external-store store + (unless store (test-skip 1)) + (test-assertm "self-contained-tarball + localstatedir" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (self-contained-tarball "tar-pack" profile + #:localstatedir? #t)) + (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? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)))))))) + (built-derivations (list check)))) + (unless store (test-skip 1)) (test-assertm "docker-image + localstatedir" store (mlet* %store-monad -- 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 'tests') 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 @@ REFERENCE-GRAPHS, a list of reference-graph files." (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 @@ REFERENCE-GRAPHS, a list of reference-graph files." (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 @@ #: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 From b07014f55ae083f589ea286fca30890a9d705153 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Nov 2018 22:54:46 +0100 Subject: pack: Add test for '--relocatable'. * tests/guix-pack-relocatable.sh: New file. * Makefile.am (SH_TESTS): Add it. --- Makefile.am | 1 + tests/guix-pack-relocatable.sh | 61 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+) create mode 100644 tests/guix-pack-relocatable.sh (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 7e4b2b9406..c63b65ba56 100644 --- a/Makefile.am +++ b/Makefile.am @@ -406,6 +406,7 @@ SH_TESTS = \ tests/guix-gc.sh \ tests/guix-hash.sh \ tests/guix-pack.sh \ + tests/guix-pack-relocatable.sh \ tests/guix-package.sh \ tests/guix-package-net.sh \ tests/guix-system.sh \ diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh new file mode 100644 index 0000000000..554416627b --- /dev/null +++ b/tests/guix-pack-relocatable.sh @@ -0,0 +1,61 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 . + +# +# Test the 'guix pack --relocatable' using the external store, if any. +# + +guix pack --version + +# 'guix pack --relocatable' requires a C compiler and libc.a, which our +# bootstrap binaries don't provide. To make the test relatively inexpensive, +# run it on 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 + +STORE_PARENT="`dirname $NIX_STORE_DIR`" +export STORE_PARENT +if test "$STORE_PARENT" = "/"; then exit 77; fi + +# This test requires user namespaces and associated command-line tools. +if ! unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"' +then + exit 77 +fi + +test_directory="`mktemp -d`" +export test_directory +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT + +tarball="`guix pack -R -S /Bin=bin sed`" +(cd "$test_directory"; tar xvf "$tarball") + +# Run that relocatable 'sed' in a user namespace where we "erase" the store by +# mounting an empty file system on top of it. That way, we exercise the +# wrapper code that creates the user namespace and bind-mounts the store. +unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"; echo "$STORE_PARENT"/*; "$test_directory/Bin/sed" --version > "$test_directory/output"' +grep 'GNU sed' "$test_directory/output" -- cgit v1.2.3 From 652163154c06b47936a453f44ea35938789718de Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 11 Nov 2018 17:13:20 +0100 Subject: guix package: '--show' errors when asked for a non-existent package. Fixes . Reported by swedebugia . * guix/scripts/package.scm (process-query): Call 'leave' when 'find-packages-by-name' returns the empty list. * tests/guix-package.sh: Test it. --- guix/scripts/package.scm | 10 +++++++--- tests/guix-package.sh | 4 ++++ 2 files changed, 11 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 500fc9ac90..5743816324 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -771,9 +771,13 @@ processed, #f otherwise." (('show requested-name) (let-values (((name version) (package-name->name+version requested-name))) - (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-name name version))) + (match (find-packages-by-name name version) + (() + (leave (G_ "~a~@[@~a~]: package not found~%") name version)) + (packages + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + packages)))) #t)) (('search-paths kind) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index f7dfbfad00..7eeb4304d1 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -106,6 +106,10 @@ guix package --show=guile | grep "^name: guile" # Ensure `--show' doesn't fail for packages with non-package inputs. guix package --show=texlive +# Fail for non-existent packages or package/version pairs. +if guix package --show=does-not-exist; then false; else true; fi +if guix package --show=emacs@42; then false; else true; fi + # Search. LC_MESSAGES=C export LC_MESSAGES -- cgit v1.2.3 From 9ed86fe175c15c819d6d86681c8136ff6bc927c0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Apr 2015 21:59:25 +0200 Subject: tests: Add 'test-assertm' to (guix tests). * guix/tests.scm (test-assertm): New macro. * tests/gexp.scm (test-assertm): Remove. * tests/profiles.scm (test-assertm): Remove. * tests/challenge.scm (%store, test-assertm): Remove. * tests/debug-link.scm (%store, test-assertm): Remove. * tests/size.scm (%store, test-assertm): Remove. --- guix/tests.scm | 25 +++++++++++++++++++++++++ tests/challenge.scm | 8 -------- tests/debug-link.scm | 8 -------- tests/gexp.scm | 5 ----- tests/profiles.scm | 11 ----------- tests/size.scm | 8 -------- 6 files changed, 25 insertions(+), 40 deletions(-) (limited to 'tests') diff --git a/guix/tests.scm b/guix/tests.scm index bcf9b990e5..66524ddc2f 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -27,6 +27,7 @@ #:use-module (guix build-system gnu) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (web uri) @@ -39,6 +40,8 @@ shebang-too-long? mock %test-substitute-urls + test-assertm + test-equalm %substitute-directory with-derivation-narinfo with-derivation-substitute @@ -161,6 +164,28 @@ given by REPLACEMENT." (lambda () body ...) (lambda () (module-set! m 'proc original))))) +(define-syntax-rule (test-assertm name exp) + "Like 'test-assert', but EXP is a monadic value. A new connection to the +store is opened." + (test-assert name + (let ((store (open-connection-for-tests))) + (dynamic-wind + (const #t) + (lambda () + (run-with-store store exp + #:guile-for-build (%guile-for-build))) + (lambda () + (close-connection store)))))) + +(define-syntax-rule (test-equalm name value exp) + "Like 'test-equal', but EXP is a monadic value. A new connection to the +store is opened." + (test-equal name + value + (with-store store + (run-with-store store exp + #:guile-for-build (%guile-for-build))))) + ;;; ;;; Narinfo files, as used by the substituter. diff --git a/tests/challenge.scm b/tests/challenge.scm index 4b13ec278e..c962800f3f 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -31,17 +31,9 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match)) -(define %store - (open-connection-for-tests)) - (define query-path-hash* (store-lift query-path-hash)) -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (define* (call-with-derivation-narinfo* drv thunk hash) (lambda (store) (with-derivation-narinfo drv (sha256 => hash) diff --git a/tests/debug-link.scm b/tests/debug-link.scm index 2dde3cb460..a1ae4f141c 100644 --- a/tests/debug-link.scm +++ b/tests/debug-link.scm @@ -43,14 +43,6 @@ (define read-elf (compose parse-elf get-bytevector-all)) -(define %store - (open-connection-for-tests)) - -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (test-begin "debug-link") diff --git a/tests/gexp.scm b/tests/gexp.scm index 467370f8cb..ab60bdab68 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -62,11 +62,6 @@ #:target target) #:guile-for-build (%guile-for-build))) -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (define %extension-package ;; Example of a package to use when testing 'with-extensions'. (dummy-package "extension" diff --git a/tests/profiles.scm b/tests/profiles.scm index 9f366a04ef..1f9bbd099d 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -47,17 +47,6 @@ ;; 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-syntax-rule (test-equalm name value exp) - (test-equal name - value - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - ;; Example manifest entries. (define guile-1.8.8 diff --git a/tests/size.scm b/tests/size.scm index 575b1abfdd..0aaa8fbc29 100644 --- a/tests/size.scm +++ b/tests/size.scm @@ -30,14 +30,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-64)) -(define %store - (open-connection-for-tests)) - -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (test-begin "size") -- cgit v1.2.3 From 3ed56ad09b1d2be15e98d195b56886ec14899518 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 Nov 2018 11:15:41 +0100 Subject: tests: Remove check for a feature that appeared in Guile 2.0.10. * tests/nar.scm: Remove test for 'open-sha256-input-port'. --- tests/nar.scm | 7 ------- 1 file changed, 7 deletions(-) (limited to 'tests') diff --git a/tests/nar.scm b/tests/nar.scm index d610ea53f7..ff16c3c400 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -332,13 +332,6 @@ (lambda () (rmdir input))))) -;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn -;; relies on a Guile 2.0.10+ feature. -(test-skip (if (false-if-exception - (open-sha256-input-port (%make-void-port "r"))) - 0 - 3)) - (test-assert "restore-file-set (signed, valid)" (with-store store (let* ((texts (unfold (cut >= <> 10) -- cgit v1.2.3 From 8390869811f56f5b2ff947efb9d48bcf219a0444 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 Nov 2018 11:38:00 +0100 Subject: tests: Check file canonicalization for 'restore-file-set'. * guix/tests.scm (canonical-file?): New procedure. * tests/nar.scm ("restore-file-set (signed, valid)"): Check that every item of FILES matches 'canonical-file?'. --- guix/tests.scm | 9 +++++++++ tests/nar.scm | 5 ++++- 2 files changed, 13 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/tests.scm b/guix/tests.scm index 66524ddc2f..f4948148c4 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -36,6 +36,7 @@ random-text random-bytevector file=? + canonical-file? network-reachable? shebang-too-long? mock @@ -150,6 +151,14 @@ too expensive to build entirely in the test store." (else (error "what?" (lstat a)))))) +(define (canonical-file? file) + "Return #t if FILE is in the store, is read-only, and its mtime is 1." + (let ((st (lstat file))) + (or (not (string-prefix? (%store-prefix) file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 (stat:mode st))))))) + (define (network-reachable?) "Return true if we can reach the Internet." (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) diff --git a/tests/nar.scm b/tests/nar.scm index ff16c3c400..bf1b066687 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -25,6 +25,8 @@ #:select (open-sha256-port open-sha256-input-port)) #:use-module ((guix packages) #:select (base32)) + #:use-module ((guix build utils) + #:select (find-files)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -354,7 +356,8 @@ (map (lambda (file) (call-with-input-file file get-string-all)) - files)))))))) + files)) + (every canonical-file? files))))))) (test-assert "restore-file-set (missing signature)" (let/ec return -- cgit v1.2.3 From f5a2724ae453f4a4b55ff848f4ad7e30efb6eef8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 13 Nov 2018 14:20:27 +0100 Subject: deduplication: Restore directory mtime and permissions after deduplication. Fixes . * guix/store/deduplication.scm (replace-with-link): Call 'set-file-time' and 'chmod' after 'rename-file'. * tests/nar.scm ("restore-file-set with directories (signed, valid)"): New test. --- guix/store/deduplication.scm | 12 +++++++++--- tests/nar.scm | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 44 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 53810c680f..21b0c81f3d 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -102,11 +102,17 @@ LINK-PREFIX." SWAP-DIRECTORY as the directory to store temporary hard links. Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." - (let ((temp-link (get-temp-link target swap-directory))) - (make-file-writable (dirname to-replace)) + (let* ((temp-link (get-temp-link target swap-directory)) + (parent (dirname to-replace)) + (stat (stat parent))) + (make-file-writable parent) (catch 'system-error (lambda () - (rename-file temp-link to-replace)) + (rename-file temp-link to-replace) + + ;; Restore PARENT's mtime and permissions. + (set-file-time parent stat) + (chmod parent (stat:mode stat))) (lambda args (delete-file temp-link) (unless (= EMLINK (system-error-errno args)) diff --git a/tests/nar.scm b/tests/nar.scm index bf1b066687..5ffe68c9e2 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -359,6 +359,41 @@ files)) (every canonical-file? files))))))) +(test-assert "restore-file-set with directories (signed, valid)" + ;; describes a bug whereby directories + ;; containing files subject to deduplication were not canonicalized--i.e., + ;; their mtime and permissions were not reset. Ensure that this bug is + ;; gone. + (with-store store + (let* ((text1 (random-text)) + (text2 (random-text)) + (tree `("tree" directory + ("a" regular (data ,text1)) + ("b" directory + ("c" regular (data ,text2)) + ("d" regular (data ,text1))))) ;duplicate + (file (add-file-tree-to-store store tree)) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <>)))) + (delete-paths store (list file)) + (and (not (file-exists? file)) + (let* ((source (open-bytevector-input-port dump)) + (imported (restore-file-set source))) + (and (equal? imported (list file)) + (file-exists? file) + (valid-path? store file) + (string=? text1 + (call-with-input-file (string-append file "/a") + get-string-all)) + (string=? text2 + (call-with-input-file + (string-append file "/b/c") + get-string-all)) + (= (stat:ino (stat (string-append file "/a"))) ;deduplication + (stat:ino (stat (string-append file "/b/d")))) + (every canonical-file? + (find-files file #:directories? #t)))))))) + (test-assert "restore-file-set (missing signature)" (let/ec return (with-store store -- cgit v1.2.3 From 3b32891b12ee18c57b0fc346ed7dce8b6976066b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 Nov 2018 18:25:13 +0100 Subject: lint: 'check-derivation' tries all the package's supported systems. This allows us to catch architecture-specific evaluation failures. * guix/scripts/lint.scm (check-derivation): Move body into... [try]: ... this. New procedure. Call 'try' for each supported system of PACKAGE. --- guix/scripts/lint.scm | 54 ++++++++++++++++++++++++++++----------------------- tests/lint.scm | 4 ++-- 2 files changed, 32 insertions(+), 26 deletions(-) (limited to 'tests') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e477bf0ddc..e8cf2dc1ff 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -774,30 +774,36 @@ descriptions maintained upstream." (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." - (catch #t - (lambda () - (guard (c ((nix-protocol-error? c) - (emit-warning package - (format #f (G_ "failed to create derivation: ~a") - (nix-protocol-error-message c)))) - ((message-condition? c) - (emit-warning package - (format #f (G_ "failed to create derivation: ~a") - (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (package-derivation store package #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement #:graft? #f)))))) - (lambda args - (emit-warning package - (format #f (G_ "failed to create derivation: ~s~%") - args))))) + (define (try system) + (catch #t + (lambda () + (guard (c ((nix-protocol-error? c) + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~a") + system + (nix-protocol-error-message c)))) + ((message-condition? c) + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~a") + system + (condition-message c))))) + (with-store store + ;; Disable grafts since it can entail rebuilds. + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f)))))) + (lambda args + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~s") + system args))))) + + (for-each try (package-supported-systems package))) (define (check-license package) "Warn about type errors of the 'license' field of PACKAGE." diff --git a/tests/lint.scm b/tests/lint.scm index ab0e8b9a8c..300153e24e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014, 2015, 2016 Eric Bavier -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost @@ -365,7 +365,7 @@ (arguments '(#:imported-modules (invalid-module)))))) (check-derivation pkg))) - "failed to create derivation"))) + "failed to create"))) (test-assert "license: invalid license" (string-contains -- cgit v1.2.3 From 08f410834bffbe1e55633a0a4c87caba69d7fa92 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 20 Oct 2018 19:28:05 +0200 Subject: pack: Add '--profile-name'. * guix/scripts/pack.scm (self-contained-tarball): Add #:profile-name and honor it. (squashfs-image, docker-image): Add #:profile-name. (%default-options): Add 'profile-name'. (%options, show-help): Add "--profile-name". (guix-pack): Honor it. * tests/guix-pack-localstatedir.sh: New file. * Makefile.am (SH_TESTS): Add it. * doc/guix.texi (Invoking guix pack): Document "--profile-name". --- Makefile.am | 1 + doc/guix.texi | 7 ++-- guix/scripts/pack.scm | 20 +++++++++++- tests/guix-pack-localstatedir.sh | 69 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 94 insertions(+), 3 deletions(-) create mode 100644 tests/guix-pack-localstatedir.sh (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index eda87f3124..70ec2e52ef 100644 --- a/Makefile.am +++ b/Makefile.am @@ -410,6 +410,7 @@ SH_TESTS = \ tests/guix-gc.sh \ tests/guix-hash.sh \ tests/guix-pack.sh \ + tests/guix-pack-localstatedir.sh \ tests/guix-pack-relocatable.sh \ tests/guix-package.sh \ tests/guix-package-net.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index 648f3e50bd..594aca731a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3488,8 +3488,11 @@ 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. +@itemx --profile-name=@var{name} +Include the ``local state directory'', @file{/var/guix}, in the resulting +pack, and notably the @file{/var/guix/profiles/per-user/root/@var{name}} +profile---by default @var{name} is @code{guix-profile}, which corresponds to +@file{~root/.guix-profile}. @file{/var/guix} contains the store database (@pxref{The Store}) as well as garbage-collector roots (@pxref{Invoking guix gc}). Providing it in diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index a86b95dd38..ce46f549cc 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -149,6 +149,7 @@ dependencies are registered." (define* (self-contained-tarball name profile #:key target + (profile-name "guix-profile") deduplicate? (compressor (first %compressors)) localstatedir? @@ -221,6 +222,7 @@ added to the pack." ;; . (populate-single-profile-directory %root #:profile #$profile + #:profile-name #$profile-name #:closure "profile" #:database #+database) @@ -279,6 +281,7 @@ added to the pack." (define* (squashfs-image name profile #:key target + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -377,6 +380,7 @@ added to the pack." (define* (docker-image name profile #:key target + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -587,6 +591,7 @@ please email '~a'~%") (define %default-options ;; Alist of default option values. `((format . tarball) + (profile-name . "guix-profile") (system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) @@ -658,6 +663,13 @@ please email '~a'~%") (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) + (option '("profile-name") #t #f + (lambda (opt name arg result) + (match arg + ((or "guix-profile" "current-guix") + (alist-cons 'profile-name arg result)) + (_ + (leave (G_ "~a: unsupported profile name~%") arg))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -690,6 +702,9 @@ Create a bundle of PACKAGE.\n")) -m, --manifest=FILE create a pack with the manifest from FILE")) (display (G_ " --localstatedir include /var/guix in the resulting pack")) + (display (G_ " + --profile-name=NAME + populate /var/guix/profiles/.../NAME")) (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) @@ -779,7 +794,8 @@ Create a bundle of PACKAGE.\n")) (#f (leave (G_ "~a: unknown pack format~%") pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (profile-name (assoc-ref opts 'profile-name))) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest @@ -798,6 +814,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? + #:profile-name + profile-name #:archiver archiver))) (mbegin %store-monad diff --git a/tests/guix-pack-localstatedir.sh b/tests/guix-pack-localstatedir.sh new file mode 100644 index 0000000000..b734b0f7e3 --- /dev/null +++ b/tests/guix-pack-localstatedir.sh @@ -0,0 +1,69 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 . + +# +# Test the 'guix pack --localstatedir' command-line utility. +# + +guix pack --version + +# 'guix pack --localstatedir' produces derivations that depend on +# guile-sqlite3 and guile-gcrypt. 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 + +# Build a tarball with '--localstatedir' +the_pack="`guix pack -C none --localstatedir --profile-name=current-guix \ + guile-bootstrap`" +test_directory="`mktemp -d`" +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT + +cd "$test_directory" +tar -xf "$the_pack" + +profile="`find -name current-guix`" +test "`readlink $profile`" = "current-guix-1-link" +test -s "`dirname $profile`/../../../db/db.sqlite" +test -x ".`guix build guile-bootstrap`/bin/guile" +cd - + +# Make sure the store database is not completely bogus. +guile -c "(use-modules (sqlite3) (guix config) (ice-9 match)) + + (define db + (sqlite-open (string-append \"$test_directory\" + %localstatedir + \"/guix/db/db.sqlite\") + SQLITE_OPEN_READONLY)) + + (define stmt + (sqlite-prepare db \"SELECT * FROM ValidPaths;\")) + + (match (sqlite-fold cons '() stmt) + ((#(ids paths hashes times derivers sizes) ...) + (exit (member \"`guix build guile-bootstrap`\" paths))))" -- cgit v1.2.3 From 8856f409d13cd7376be4319b9f75df0692c009d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:14:11 +0100 Subject: derivations: Add properties. * guix/derivations.scm (derivation): Add #:properties parameter. [user+system-env-vars]: Honor it. (derivation-properties): New procedure. (build-expression->derivation): Add #:properties and pass it to 'derivation'. * guix/gexp.scm (gexp->derivation): Likewise. * tests/derivations.scm ("derivation-properties"): New test. * tests/gexp.scm ("gexp->derivation properties"): New test. * doc/guix.texi (Derivations, G-Expressions): Adjust accordingly. --- doc/guix.texi | 8 ++++++-- guix/derivations.scm | 30 +++++++++++++++++++++++++----- guix/gexp.scm | 4 +++- tests/derivations.scm | 10 ++++++++++ tests/gexp.scm | 10 +++++++++- 5 files changed, 53 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 917a3e9d57..c040a8531a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5060,7 +5060,7 @@ a derivation is the @code{derivation} procedure: [#:system (%current-system)] [#:references-graphs #f] @ [#:allowed-references #f] [#:disallowed-references #f] @ [#:leaked-env-vars #f] [#:local-build? #f] @ - [#:substitutable? #t] + [#:substitutable? #t] [#:properties '()] Build a derivation with the given arguments, and return the resulting @code{} object. @@ -5097,6 +5097,9 @@ When @var{substitutable?} is false, declare that substitutes of the derivation's output should not be used (@pxref{Substitutes}). This is useful, for instance, when building packages that capture details of the host CPU instruction set. + +@var{properties} must be an association list describing ``properties'' of the +derivation. It is kept as-is, uninterpreted, in the derivation. @end deffn @noindent @@ -5790,7 +5793,8 @@ information about monads.) [#:leaked-env-vars #f] @ [#:script-name (string-append @var{name} "-builder")] @ [#:deprecation-warnings #f] @ - [#:local-build? #f] [#:substitutable? #t] [#:guile-for-build #f] + [#:local-build? #f] [#:substitutable? #t] @ + [#:properties '()] [#:guile-for-build #f] Return a derivation @var{name} that runs @var{exp} (a gexp) with @var{guile-for-build} (a derivation) on @var{system}; @var{exp} is stored in a file called @var{script-name}. When @var{target} is true, diff --git a/guix/derivations.scm b/guix/derivations.scm index 7afecb10cc..f6176a78fd 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -80,6 +80,7 @@ substitutable-derivation? substitution-oracle derivation-hash + derivation-properties read-derivation read-derivation-from-file @@ -681,7 +682,8 @@ name of each input with that input's hash." references-graphs allowed-references disallowed-references leaked-env-vars local-build? - (substitutable? #t)) + (substitutable? #t) + (properties '())) "Build a derivation with the given arguments, and return the resulting object. When HASH and HASH-ALGO are given, a fixed-output derivation is created---i.e., one whose result is known in @@ -708,7 +710,10 @@ for offloading and should rather be built locally. This is the case for small derivations where the costs of data transfers would outweigh the benefits. When SUBSTITUTABLE? is false, declare that substitutes of the derivation's -output should not be used." +output should not be used. + +PROPERTIES must be an association list describing \"properties\" of the +derivation. It is kept as-is, uninterpreted, in the derivation." (define (add-output-paths drv) ;; Return DRV with an actual store path for each of its output and the ;; corresponding environment variable. @@ -763,6 +768,10 @@ output should not be used." `(("impureEnvVars" . ,(string-join leaked-env-vars))) '()) + ,@(match properties + (() '()) + (lst `(("guix properties" + . ,(object->string properties))))) ,@env-vars))) (match references-graphs (((file . path) ...) @@ -851,6 +860,14 @@ long-running processes that know what they're doing. Use with care!" (invalidate-memoization! derivation-path->base16-hash) (hash-clear! %derivation-cache)) +(define derivation-properties + (mlambdaq (drv) + "Return the property alist associated with DRV." + (match (assoc "guix properties" + (derivation-builder-environment-vars drv)) + ((_ . str) (call-with-input-string str read)) + (#f '())))) + (define* (map-derivation store drv mapping #:key (system (%current-system))) "Given MAPPING, a list of pairs of derivations, return a derivation based on @@ -1129,7 +1146,8 @@ they can refer to each other." references-graphs allowed-references disallowed-references - local-build? (substitutable? #t)) + local-build? (substitutable? #t) + (properties '())) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list @@ -1149,7 +1167,8 @@ EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is omitted or is #f, the value of the `%guile-for-build' fluid is used instead. See the `derivation' procedure for the meaning of REFERENCES-GRAPHS, -ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." +ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, SUBSTITUTABLE?, +and PROPERTIES." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1277,7 +1296,8 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." #:allowed-references allowed-references #:disallowed-references disallowed-references #:local-build? local-build? - #:substitutable? substitutable?))) + #:substitutable? substitutable? + #:properties properties))) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index f33fb198e4..786e378308 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -631,6 +631,7 @@ names and file names suitable for the #:allowed-references argument to allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) + (properties '()) ;; TODO: This parameter is transitional; it's here ;; to avoid a full rebuild. Remove it on the next @@ -800,7 +801,8 @@ The other arguments are as for 'derivation'." #:disallowed-references disallowed #:leaked-env-vars leaked-env-vars #:local-build? local-build? - #:substitutable? substitutable?)))) + #:substitutable? substitutable? + #:properties properties)))) (define* (gexp-inputs exp #:key native?) "Return the input list for EXP. When NATIVE? is true, return only native diff --git a/tests/derivations.scm b/tests/derivations.scm index 159a6971b3..5f294c1827 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1132,6 +1132,16 @@ ((p2 . _) (stringderivation %store "bar" + '(mkdir %output))) + (drv2 (build-expression->derivation %store "foo" + '(mkdir %output) + #:properties '((type . test))))) + (list (derivation-properties drv1) + (derivation-properties drv2)))) + (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8)) diff --git a/tests/gexp.scm b/tests/gexp.scm index ab60bdab68..7ae9201c81 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -476,7 +476,15 @@ (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) - (equal? refs2 (list file)))))) + (equal? refs2 (list file)) + (null? (derivation-properties drv)))))) + +(test-assertm "gexp->derivation properties" + (mlet %store-monad ((drv (gexp->derivation "foo" + #~(mkdir #$output) + #:properties '((type . test))))) + (return (equal? '((type . test)) + (derivation-properties drv))))) (test-assertm "gexp->derivation vs. grafts" (mlet* %store-monad ((graft? (set-grafting #f)) -- cgit v1.2.3 From 64fd1c01bc6f1be6ffcafc08789d5dafb9850c2e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:27:39 +0100 Subject: grafts: Record metadata as derivation properties. * guix/grafts.scm (graft-derivation/shallow): Pass #:properties to 'build-expression->derivation'. * tests/grafts.scm ("graft-derivation, grafted item is a direct dependency"): Check the value returned by 'derivation-properties'. --- guix/grafts.scm | 7 ++++++- tests/grafts.scm | 13 ++++++++----- 2 files changed, 14 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/guix/grafts.scm b/guix/grafts.scm index 01e245d8eb..63f384555b 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -123,6 +123,10 @@ are not recursively applied to dependencies of DRV." (define add-label (cut cons "x" <>)) + (define properties + `((type . graft) + (graft (count . ,(length grafts))))) + (match grafts ((($ sources source-outputs targets target-outputs) ...) (let ((sources (zip sources source-outputs)) @@ -140,7 +144,8 @@ are not recursively applied to dependencies of DRV." ,@(append (map add-label sources) (map add-label targets))) #:outputs outputs - #:local-build? #t))))) + #:local-build? #t + #:properties properties))))) (define (item->deriver store item) "Return two values: the derivation that led to ITEM (a store item), and the name of the output of that derivation ITEM corresponds to (for example diff --git a/tests/grafts.scm b/tests/grafts.scm index abb074d628..f85f3c6913 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +51,8 @@ (test-begin "grafts") -(test-assert "graft-derivation, grafted item is a direct dependency" +(test-equal "graft-derivation, grafted item is a direct dependency" + '((type . graft) (graft (count . 2))) (let* ((build `(begin (mkdir %output) (chdir %output) @@ -76,14 +77,16 @@ (origin %mkdir) (replacement two)))))) (and (build-derivations %store (list grafted)) - (let ((two (derivation->output-path two)) - (grafted (derivation->output-path grafted))) + (let ((properties (derivation-properties grafted)) + (two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) (call-with-input-file (string-append grafted "/text") get-string-all)) (string=? (readlink (string-append grafted "/sh")) one) (string=? (readlink (string-append grafted "/self")) - grafted)))))) + grafted) + properties))))) (test-assert "graft-derivation, grafted item uses a different name" (let* ((build `(begin -- cgit v1.2.3 From 94c0e61fe759924625c9e27d3da8c7c0c767ea2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 11:48:33 +0100 Subject: inferior: Add 'inferior-eval-with-store'. * guix/inferior.scm (inferior-eval-with-store): New procedure, with code formerly in 'inferior-package-derivation'. (inferior-package-derivation): Rewrite in terms of 'inferior-eval-with-store'. * tests/inferior.scm ("inferior-eval-with-store"): New test. --- guix/inferior.scm | 70 +++++++++++++++++++++++++++++++++--------------------- tests/inferior.scm | 9 +++++++ 2 files changed, 52 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/guix/inferior.scm b/guix/inferior.scm index 1dbb9e1699..ccc1c27cb2 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -56,6 +56,7 @@ open-inferior close-inferior inferior-eval + inferior-eval-with-store inferior-object? inferior-packages @@ -402,55 +403,70 @@ input/output ports.)" (unless (port-closed? client) (loop)))))) -(define* (inferior-package-derivation store package - #:optional - (system (%current-system)) - #:key target) - "Return the derivation for PACKAGE, an inferior package, built for SYSTEM -and cross-built for TARGET if TARGET is true. The inferior corresponding to -PACKAGE must be live." - ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to - ;; it and use it as its store. This ensures the inferior uses the same - ;; store, with the same options, the same per-session GC roots, etc. +(define (inferior-eval-with-store inferior store code) + "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must +thus be the code of a one-argument procedure that accepts a store." + ;; Create a named socket in /tmp and let INFERIOR connect to it and use it + ;; as its store. This ensures the inferior uses the same store, with the + ;; same options, the same per-session GC roots, etc. (call-with-temporary-directory (lambda (directory) (chmod directory #o700) (let* ((name (string-append directory "/inferior")) (socket (socket AF_UNIX SOCK_STREAM 0)) - (inferior (inferior-package-inferior package)) (major (nix-server-major-version store)) (minor (nix-server-minor-version store)) (proto (logior major minor))) (bind socket AF_UNIX name) (listen socket 1024) (send-inferior-request - `(let ((socket (socket AF_UNIX SOCK_STREAM 0))) + `(let ((proc ,code) + (socket (socket AF_UNIX SOCK_STREAM 0))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly ;; emulate it on older versions. Thus fall back to ;; 'open-connection', at the risk of talking to the wrong daemon or ;; having our build result reclaimed (XXX). - (let* ((store (if (defined? 'port->connection) - (port->connection socket #:version ,proto) - (open-connection))) - (package (hashv-ref %package-table - ,(inferior-package-id package))) - (drv ,(if target - `(package-cross-derivation store package - ,target - ,system) - `(package-derivation store package - ,system)))) - (close-connection store) - (close-port socket) - (derivation-file-name drv))) + (let ((store (if (defined? 'port->connection) + (port->connection socket #:version ,proto) + (open-connection)))) + (dynamic-wind + (const #t) + (lambda () + (proc store)) + (lambda () + (close-connection store) + (close-port socket))))) inferior) (match (accept socket) ((client . address) (proxy client (nix-server-socket store)))) (close-port socket) - (read-derivation-from-file (read-inferior-response inferior)))))) + (read-inferior-response inferior))))) + +(define* (inferior-package-derivation store package + #:optional + (system (%current-system)) + #:key target) + "Return the derivation for PACKAGE, an inferior package, built for SYSTEM +and cross-built for TARGET if TARGET is true. The inferior corresponding to +PACKAGE must be live." + (define proc + `(lambda (store) + (let* ((package (hashv-ref %package-table + ,(inferior-package-id package))) + (drv ,(if target + `(package-cross-derivation store package + ,target + ,system) + `(package-derivation store package + ,system)))) + (derivation-file-name drv)))) + + (and=> (inferior-eval-with-store (inferior-package-inferior package) store + proc) + read-derivation-from-file)) (define inferior-package->derivation (store-lift inferior-package-derivation)) diff --git a/tests/inferior.scm b/tests/inferior.scm index d1d5c00a77..d5a894ca8f 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -157,6 +157,15 @@ (close-inferior inferior) result)) +(test-equal "inferior-eval-with-store" + (add-text-to-store %store "foo" "Hello, world!") + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "foo" + "Hello, world!"))))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From 96915a448cfe8383a1c47f4b9a1cc810e5161fd0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Nov 2018 15:34:34 +0100 Subject: guix build: Add '--with-branch' transformation option. * guix/scripts/build.scm (evaluate-git-replacement-specs) (transform-package-source-branch): New procedures. (%transformations, %transformation-options): Add 'with-branch'. (show-transformation-options-help): Likewise. * tests/guix-build-branch.sh: New file. * Makefile.am (SH_TESTS): Add it. * doc/guix.texi (Package Transformation Options): Document it. --- Makefile.am | 1 + doc/guix.texi | 27 ++++++++++++++++++++++ guix/scripts/build.scm | 56 +++++++++++++++++++++++++++++++++++++++++++--- tests/guix-build-branch.sh | 48 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 129 insertions(+), 3 deletions(-) create mode 100644 tests/guix-build-branch.sh (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 05c450c4f3..e14ac57f2f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -407,6 +407,7 @@ endif SH_TESTS = \ tests/guix-build.sh \ + tests/guix-build-branch.sh \ tests/guix-download.sh \ tests/guix-gc.sh \ tests/guix-hash.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index c040a8531a..491de5c843 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6451,6 +6451,33 @@ must be compatible. If @var{replacement} is somehow incompatible with @var{package}, then the resulting package may be unusable. Use with care! +@item --with-branch=@var{package}=@var{branch} +@cindex Git, using the latest commit +@cindex latest commit, building +Build @var{package} from the latest commit of @var{branch}. The @code{source} +field of @var{package} must be an origin with the @code{git-fetch} method +(@pxref{origin Reference}) or a @code{git-checkout} object; the repository URL +is taken from that @code{source}. + +For instance, the following command builds @code{guile-sqlite3} from the +latest commit of its @code{master} branch, and then builds @code{guix} (which +depends on it) and @code{cuirass} (which depends on @code{guix}) against this +specific @code{guile-sqlite3} build: + +@example +guix build --with-branch=guile-sqlite3=master cuirass +@end example + +@cindex continuous integration +Obviously, since it uses the latest commit of the given branch, the result of +such a command varies over time. Nevertheless it is a convenient way to +rebuild entire software stacks against the latest commit of one or more +packages. This is particularly useful in the context of continuous +integration (CI). + +Checkouts are kept in a cache under @file{~/.cache/guix/checkouts} to speed up +consecutive accesses to the same repository. You may want to clean it up once +in a while to save disk space. @end table @node Additional Build Options diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 13978abb77..e8f2fe973d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,8 @@ #:use-module (srfi srfi-37) #:autoload (gnu packages) (specification->package %package-module-path) #:autoload (guix download) (download-to-store) + #:autoload (guix git-download) (git-reference?) + #:autoload (guix git) (git-checkout?) #:use-module (guix status) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) @@ -270,6 +272,48 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (rewrite obj) obj)))) +(define (evaluate-git-replacement-specs specs) + "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list +of package pairs. Raise an error if an element of SPECS uses invalid syntax, +or if a package it refers to could not be found." + (define not-equal + (char-set-complement (char-set #\=))) + + (map (lambda (spec) + (match (string-tokenize spec not-equal) + ((name branch) + (let* ((old (specification->package name)) + (source (package-source old)) + (url (cond ((and (origin? source) + (git-reference? (origin-uri source))) + (git-reference-url (origin-uri source))) + ((git-checkout? source) + (git-checkout-url source)) + (else + (leave (G_ "the source of ~a is not a Git \ +reference~%") + (package-full-name old)))))) + (cons old + (package + (inherit old) + (version (string-append "git." branch)) + (source (git-checkout (url url) (branch branch))))))) + (x + (leave (G_ "invalid replacement specification: ~s~%") spec)))) + specs)) + +(define (transform-package-source-branch replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=stable-3.0\" meaning that packages are built using +'guile-next' from the latest commit on its 'stable-3.0' branch." + (let* ((replacements (evaluate-git-replacement-specs replacement-specs)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -277,7 +321,8 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." ;; things to build. `((with-source . ,transform-package-source) (with-input . ,transform-package-inputs) - (with-graft . ,transform-package-inputs/graft))) + (with-graft . ,transform-package-inputs/graft) + (with-branch . ,transform-package-source-branch))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -291,7 +336,9 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (option '("with-input") #t #f (parser 'with-input)) (option '("with-graft") #t #f - (parser 'with-graft))))) + (parser 'with-graft)) + (option '("with-branch") #t #f + (parser 'with-branch))))) (define (show-transformation-options-help) (display (G_ " @@ -302,7 +349,10 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." replace dependency PACKAGE by REPLACEMENT")) (display (G_ " --with-graft=PACKAGE=REPLACEMENT - graft REPLACEMENT on packages that refer to PACKAGE"))) + graft REPLACEMENT on packages that refer to PACKAGE")) + (display (G_ " + --with-branch=PACKAGE=BRANCH + build PACKAGE from the latest commit of BRANCH"))) (define (options->transformation opts) diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh new file mode 100644 index 0000000000..bc50d9c0ef --- /dev/null +++ b/tests/guix-build-branch.sh @@ -0,0 +1,48 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 . + +# +# Test 'guix build --with-branch'. +# + +guix build --version + +# 'guix build --with-branch' requires access to the network to clone the +# Git repository below. + +if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null +then + # Skipping. + exit 77 +fi + +orig_drv="`guix build guile-gcrypt -d`" +latest_drv="`guix build guile-gcrypt --with-branch=guile-gcrypt=master -d`" +test -n "$latest_drv" +test "$orig_drv" != "$latest_drv" + +# FIXME: '-S' currently doesn't work with non-derivation source. +# checkout="`guix build guile-gcrypt --with-branch=guile-gcrypt=master -S`" +checkout="`guix gc --references "$latest_drv" | grep guile-gcrypt | grep -v -E '(-builder|\.drv)'`" +test -d "$checkout" +test -f "$checkout/COPYING" + +orig_drv="`guix build guix -d`" +latest_drv="`guix build guix --with-branch=guile-gcrypt=master -d`" +guix gc -R "$latest_drv" | grep guile-gcrypt-git.master +test "$orig_drv" != "$latest_drv" -- cgit v1.2.3 From b18f7234aac9eb42097c1b4cda7efe0be5aab132 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 30 Nov 2018 13:24:48 +0100 Subject: guix build: Add '--with-commit'. * guix/git.scm ()[commit]: New field. (git-checkout-compiler): Honor it. * guix/scripts/build.scm (evaluate-git-replacement-specs): Add 'proc' parameter and honor it. (transform-package-source-branch)[replace]: New procedure. Adjust 'evaluate-git-replacement-specs' accordingly. (transform-package-source-commit): New procedure. (%transformations, %transformation-options) (show-transformation-options-help): Add 'with-commit'. * tests/guix-build-branch.sh: Add test. * doc/guix.texi (Package Transformation Options): Document it. --- doc/guix.texi | 5 ++++ guix/git.scm | 11 +++++---- guix/scripts/build.scm | 60 +++++++++++++++++++++++++++++++++++----------- tests/guix-build-branch.sh | 5 ++++ 4 files changed, 63 insertions(+), 18 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 491de5c843..fff5dfe0bf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6478,6 +6478,11 @@ integration (CI). Checkouts are kept in a cache under @file{~/.cache/guix/checkouts} to speed up consecutive accesses to the same repository. You may want to clean it up once in a while to save disk space. + +@item --with-commit=@var{package}=@var{commit} +This is similar to @code{--with-branch}, except that it builds from +@var{commit} rather than the tip of a branch. @var{commit} must be a valid +Git commit SHA1 identifier. @end table @node Additional Build Options diff --git a/guix/git.scm b/guix/git.scm index 56cebb06ed..f5593ab57c 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -198,12 +198,13 @@ Log progress and checkout info to LOG-PORT." ;;; Checkouts. ;;; -;; Representation of the "latest" checkout of a branch. +;; Representation of the "latest" checkout of a branch or a specific commit. (define-record-type* git-checkout make-git-checkout git-checkout? (url git-checkout-url) - (branch git-checkout-branch (default "master"))) + (branch git-checkout-branch (default "master")) + (commit git-checkout-commit (default #f))) (define latest-repository-commit* (store-lift latest-repository-commit)) @@ -213,7 +214,9 @@ Log progress and checkout info to LOG-PORT." ;; "Compile" CHECKOUT by updating the local checkout and adding it to the ;; store. (match checkout - (($ url branch) + (($ url branch commit) (latest-repository-commit* url - #:ref `(branch . ,branch) + #:ref (if commit + `(commit . ,commit) + `(branch . ,branch)) #:log-port (current-error-port))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index e8f2fe973d..5532c65eb6 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -272,16 +272,17 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (rewrite obj) obj)))) -(define (evaluate-git-replacement-specs specs) +(define (evaluate-git-replacement-specs specs proc) "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list -of package pairs. Raise an error if an element of SPECS uses invalid syntax, -or if a package it refers to could not be found." +of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the +replacement package. Raise an error if an element of SPECS uses invalid +syntax, or if a package it refers to could not be found." (define not-equal (char-set-complement (char-set #\=))) (map (lambda (spec) (match (string-tokenize spec not-equal) - ((name branch) + ((name branch-or-commit) (let* ((old (specification->package name)) (source (package-source old)) (url (cond ((and (origin? source) @@ -293,11 +294,7 @@ or if a package it refers to could not be found." (leave (G_ "the source of ~a is not a Git \ reference~%") (package-full-name old)))))) - (cons old - (package - (inherit old) - (version (string-append "git." branch)) - (source (git-checkout (url url) (branch branch))))))) + (cons old (proc old url branch-or-commit)))) (x (leave (G_ "invalid replacement specification: ~s~%") spec)))) specs)) @@ -307,7 +304,36 @@ reference~%") dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of strings like \"guile-next=stable-3.0\" meaning that packages are built using 'guile-next' from the latest commit on its 'stable-3.0' branch." - (let* ((replacements (evaluate-git-replacement-specs replacement-specs)) + (define (replace old url branch) + (package + (inherit old) + (version (string-append "git." branch)) + (source (git-checkout (url url) (branch branch))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-source-commit replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=cabba9e\" meaning that packages are built using +'guile-next' from commit 'cabba9e'." + (define (replace old url commit) + (package + (inherit old) + (version (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7)))) + (source (git-checkout (url url) (commit commit))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) (rewrite (package-input-rewriting replacements))) (lambda (store obj) (if (package? obj) @@ -322,7 +348,8 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using `((with-source . ,transform-package-source) (with-input . ,transform-package-inputs) (with-graft . ,transform-package-inputs/graft) - (with-branch . ,transform-package-source-branch))) + (with-branch . ,transform-package-source-branch) + (with-commit . ,transform-package-source-commit))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -338,7 +365,9 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (option '("with-graft") #t #f (parser 'with-graft)) (option '("with-branch") #t #f - (parser 'with-branch))))) + (parser 'with-branch)) + (option '("with-commit") #t #f + (parser 'with-commit))))) (define (show-transformation-options-help) (display (G_ " @@ -350,9 +379,12 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (display (G_ " --with-graft=PACKAGE=REPLACEMENT graft REPLACEMENT on packages that refer to PACKAGE")) - (display (G_ " + (display (G_ " --with-branch=PACKAGE=BRANCH - build PACKAGE from the latest commit of BRANCH"))) + build PACKAGE from the latest commit of BRANCH")) + (display (G_ " + --with-commit=PACKAGE=COMMIT + build PACKAGE from COMMIT"))) (define (options->transformation opts) diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index bc50d9c0ef..89c1a3cce0 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -46,3 +46,8 @@ orig_drv="`guix build guix -d`" latest_drv="`guix build guix --with-branch=guile-gcrypt=master -d`" guix gc -R "$latest_drv" | grep guile-gcrypt-git.master test "$orig_drv" != "$latest_drv" + +v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=9e3eacdec1d -d`" +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.9e3eacd +test "$v0_1_0_drv" != "$latest_drv" +test "$v0_1_0_drv" != "$orig_drv" -- cgit v1.2.3 From a3d77c51bc8f641c12989e18dc5e03add776f87e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 30 Nov 2018 16:41:22 +0100 Subject: git: Nicely report '--with-commit' errors. * guix/git.scm (latest-repository-commit*): Rewrite to catch 'git-error'. * po/guix/POTFILES.in: Add guix/git.scm. * tests/guix-build-branch.sh: Test --with-commit errors. --- guix/git.scm | 28 ++++++++++++++++++++++++++-- po/guix/POTFILES.in | 1 + tests/guix-build-branch.sh | 3 +++ 3 files changed, 30 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/git.scm b/guix/git.scm index f5593ab57c..0666f0c0a9 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -20,6 +20,7 @@ (define-module (guix git) #:use-module (git) #:use-module (git object) + #:use-module (guix i18n) #:use-module (guix base32) #:use-module (gcrypt hash) #:use-module ((guix build utils) #:select (mkdir-p)) @@ -206,8 +207,31 @@ Log progress and checkout info to LOG-PORT." (branch git-checkout-branch (default "master")) (commit git-checkout-commit (default #f))) -(define latest-repository-commit* - (store-lift latest-repository-commit)) +(define* (latest-repository-commit* url #:key ref log-port) + ;; Monadic variant of 'latest-repository-commit'. + (lambda (store) + ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so + ;; translate it into '&message' conditions that we know will be properly + ;; handled. + (catch 'git-error + (lambda () + (values (latest-repository-commit store url + #:ref ref #:log-port log-port) + store)) + (lambda (key error . _) + (raise (condition + (&message + (message + (match ref + (('commit . commit) + (format #f (G_ "cannot fetch commit ~a from ~a: ~a") + commit url (git-error-message error))) + (('branch . branch) + (format #f (G_ "cannot fetch branch '~a' from ~a: ~a") + branch url (git-error-message error))) + (_ + (format #f (G_ "Git failure while fetching ~a: ~a") + url (git-error-message error)))))))))))) (define-gexp-compiler (git-checkout-compiler (checkout ) system target) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 74c223b283..e0da801587 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -43,4 +43,5 @@ guix/http-client.scm guix/nar.scm guix/channels.scm guix/profiles.scm +guix/git.scm nix/nix-daemon/guix-daemon.cc diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index 89c1a3cce0..e64782c831 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -51,3 +51,6 @@ v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=9e3eacdec1d -d`" guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.9e3eacd test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" + +if guix build guix --with-commit=guile-gcrypt=000 -d +then false; else true; fi -- cgit v1.2.3 From af12790bdd3805bbd7bca2b7c1d9045666f377eb Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 13 Oct 2018 08:39:23 +0200 Subject: guix: Add support for channel dependencies. * guix/channels.scm (): New record. (read-channel-metadata, channel-instance-dependencies): New procedures. (latest-channel-instances): Include channel dependencies; add optional argument PREVIOUS-CHANNELS. (channel-instance-derivations): Build derivation for additional channels and add it as dependency to the channel instance derivation. * doc/guix.texi (Channels): Add subsection "Declaring Channel Dependencies". * tests/channels.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 1 + doc/guix.texi | 33 +++++++++++++ guix/channels.scm | 122 ++++++++++++++++++++++++++++++++++++++++------ tests/channels.scm | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 279 insertions(+), 16 deletions(-) create mode 100644 tests/channels.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index a7a67e81cf..4a190c4095 100644 --- a/Makefile.am +++ b/Makefile.am @@ -329,6 +329,7 @@ SCM_TESTS = \ tests/base16.scm \ tests/base32.scm \ tests/base64.scm \ + tests/channels.scm \ tests/cpan.scm \ tests/cpio.scm \ tests/crate.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 4ef2601579..20b5013fd9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3037,6 +3037,39 @@ the new and upgraded packages that are listed, some like @code{my-gimp} and @code{my-emacs-with-cool-features} might come from @code{my-personal-packages}, while others come from the Guix default channel. +@cindex dependencies, channels +@cindex meta-data, channels +@subsection Declaring Channel Dependencies + +Channel authors may decide to augment a package collection provided by other +channels. They can declare their channel to be dependent on other channels in +a meta-data file @file{.guix-channel}, which is to be placed in the root of +the channel repository. + +The meta-data file should contain a simple S-expression like this: + +@lisp +(channel + (version 0) + (dependencies + (channel + (name 'some-collection) + (url "https://example.org/first-collection.git")) + (channel + (name 'some-other-collection) + (url "https://example.org/second-collection.git") + (branch "testing")))) +@end lisp + +In the above example this channel is declared to depend on two other channels, +which will both be fetched automatically. The modules provided by the channel +will be compiled in an environment where the modules of all these declared +channels are available. + +For the sake of reliability and maintainability, you should avoid dependencies +on channels that you don't control, and you should aim to keep the number of +dependencies to a minimum. + @subsection Replicating Guix @cindex pinning, channels diff --git a/guix/channels.scm b/guix/channels.scm index e57da68149..75503bb0ae 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ #:use-module (guix store) #:use-module (guix i18n) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:autoload (guix self) (whole-package) @@ -73,7 +75,6 @@ (commit channel-commit (default #f)) (location channel-location (default (current-source-location)) (innate))) -;; TODO: Add a way to express dependencies among channels. (define %default-channels ;; Default list of channels. @@ -93,6 +94,12 @@ (commit channel-instance-commit) (checkout channel-instance-checkout)) +(define-record-type + (channel-metadata version dependencies) + channel-metadata? + (version channel-metadata-version) + (dependencies channel-metadata-dependencies)) + (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for 'latest-repository-commit'." @@ -100,20 +107,90 @@ (#f `(branch . ,(channel-branch channel))) (commit `(commit . ,(channel-commit channel))))) -(define (latest-channel-instances store channels) +(define (read-channel-metadata instance) + "Return a channel-metadata record read from the channel INSTANCE's +description file, or return #F if the channel instance does not include the +file." + (let* ((source (channel-instance-checkout instance)) + (meta-file (string-append source "/.guix-channel"))) + (and (file-exists? meta-file) + (and-let* ((raw (call-with-input-file meta-file read)) + (version (and=> (assoc-ref raw 'version) first)) + (dependencies (or (assoc-ref raw 'dependencies) '()))) + (channel-metadata + version + (map (lambda (item) + (let ((get (lambda* (key #:optional default) + (or (and=> (assoc-ref item key) first) default)))) + (and-let* ((name (get 'name)) + (url (get 'url)) + (branch (get 'branch "master"))) + (channel + (name name) + (branch branch) + (url url) + (commit (get 'commit)))))) + dependencies)))))) + +(define (channel-instance-dependencies instance) + "Return the list of channels that are declared as dependencies for the given +channel INSTANCE." + (match (read-channel-metadata instance) + (#f '()) + (($ version dependencies) + dependencies))) + +(define* (latest-channel-instances store channels #:optional (previous-channels '())) "Return a list of channel instances corresponding to the latest checkouts of -CHANNELS." - (map (lambda (channel) - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let-values (((checkout commit) - (latest-repository-commit store (channel-url channel) - #:ref (channel-reference - channel)))) - (channel-instance channel commit checkout))) - channels)) +CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list +of previously processed channels." + ;; Only process channels that are unique, or that are more specific than a + ;; previous channel specification. + (define (ignore? channel others) + (member channel others + (lambda (a b) + (and (eq? (channel-name a) (channel-name b)) + (or (channel-commit b) + (not (or (channel-commit a) + (channel-commit b)))))))) + ;; Accumulate a list of instances. A list of processed channels is also + ;; accumulated to decide on duplicate channel specifications. + (match (fold (lambda (channel acc) + (match acc + ((#:channels previous-channels #:instances instances) + (if (ignore? channel previous-channels) + acc + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let-values (((checkout commit) + (latest-repository-commit store (channel-url channel) + #:ref (channel-reference + channel)))) + (let ((instance (channel-instance channel commit checkout))) + (let-values (((new-instances new-channels) + (latest-channel-instances + store + (channel-instance-dependencies instance) + previous-channels))) + `(#:channels + ,(append (cons channel new-channels) + previous-channels) + #:instances + ,(append (cons instance new-instances) + instances)))))))))) + `(#:channels ,previous-channels #:instances ()) + channels) + ((#:channels channels #:instances instances) + (let ((instance-name (compose channel-name channel-instance-channel))) + ;; Remove all earlier channel specifications if they are followed by a + ;; more specific one. + (values (delete-duplicates instances + (lambda (a b) + (eq? (instance-name a) (instance-name b)))) + channels))))) (define* (checkout->channel-instance checkout #:key commit @@ -235,8 +312,21 @@ INSTANCES." (lambda (instance) (if (eq? instance core-instance) (return core) - (build-channel-instance instance - (cons core dependencies)))) + (match (channel-instance-dependencies instance) + (() + (build-channel-instance instance + (cons core dependencies))) + (channels + (mlet %store-monad ((dependencies-derivation + (latest-channel-derivation + ;; %default-channels is used here to + ;; ensure that the core channel is + ;; available for channels declared as + ;; dependencies. + (append channels %default-channels)))) + (build-channel-instance instance + (cons dependencies-derivation + (cons core dependencies)))))))) instances))) (define (whole-package-for-legacy name modules) diff --git a/tests/channels.scm b/tests/channels.scm new file mode 100644 index 0000000000..f3fc383ac3 --- /dev/null +++ b/tests/channels.scm @@ -0,0 +1,139 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ricardo Wurmus +;;; +;;; 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-channels) + #:use-module (guix channels) + #:use-module ((guix build syscalls) #:select (mkdtemp!)) + #:use-module (guix tests) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) + +(test-begin "channels") + +(define* (make-instance #:key + (name 'fake) + (commit "cafebabe") + (spec #f)) + (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX")) + (and spec + (with-output-to-file (string-append instance-dir "/.guix-channel") + (lambda _ (format #t "~a" spec)))) + ((@@ (guix channels) channel-instance) + name commit instance-dir)) + +(define instance--boring (make-instance)) +(define instance--no-deps + (make-instance #:spec + '(channel + (version 0) + (dependencies + (channel + (name test-channel) + (url "https://example.com/test-channel")))))) +(define instance--simple + (make-instance #:spec + '(channel + (version 0) + (dependencies + (channel + (name test-channel) + (url "https://example.com/test-channel")))))) +(define instance--with-dupes + (make-instance #:spec + '(channel + (version 0) + (dependencies + (channel + (name test-channel) + (url "https://example.com/test-channel")) + (channel + (name test-channel) + (url "https://example.com/test-channel") + (commit "abc1234")) + (channel + (name test-channel) + (url "https://example.com/test-channel-elsewhere")))))) + +(define read-channel-metadata + (@@ (guix channels) read-channel-metadata)) + + +(test-equal "read-channel-metadata returns #f if .guix-channel does not exist" + #f + (read-channel-metadata instance--boring)) + +(test-assert "read-channel-metadata returns " + (every (@@ (guix channels) channel-metadata?) + (map read-channel-metadata + (list instance--no-deps + instance--simple + instance--with-dupes)))) + +(test-assert "read-channel-metadata dependencies are channels" + (let ((deps ((@@ (guix channels) channel-metadata-dependencies) + (read-channel-metadata instance--simple)))) + (match deps + (((? channel? dep)) #t) + (_ #f)))) + +(test-assert "latest-channel-instances includes channel dependencies" + (let* ((channel (channel + (name 'test) + (url "test"))) + (test-dir (channel-instance-checkout instance--simple))) + (mock ((guix git) latest-repository-commit + (lambda* (store url #:key ref) + (match url + ("test" (values test-dir 'whatever)) + (_ (values "/not-important" 'not-important))))) + (let ((instances (latest-channel-instances #f (list channel)))) + (and (eq? 2 (length instances)) + (lset= eq? + '(test test-channel) + (map (compose channel-name channel-instance-channel) + instances))))))) + +(test-assert "latest-channel-instances excludes duplicate channel dependencies" + (let* ((channel (channel + (name 'test) + (url "test"))) + (test-dir (channel-instance-checkout instance--with-dupes))) + (mock ((guix git) latest-repository-commit + (lambda* (store url #:key ref) + (match url + ("test" (values test-dir 'whatever)) + (_ (values "/not-important" 'not-important))))) + (let ((instances (latest-channel-instances #f (list channel)))) + (and (eq? 2 (length instances)) + (lset= eq? + '(test test-channel) + (map (compose channel-name channel-instance-channel) + instances)) + ;; only the most specific channel dependency should remain, + ;; i.e. the one with a specified commit. + (find (lambda (instance) + (and (eq? (channel-name + (channel-instance-channel instance)) + 'test-channel) + (eq? (channel-commit + (channel-instance-channel instance)) + 'abc1234))) + instances)))))) + +(test-end "channels") -- cgit v1.2.3