From ac1d530d56c1a259630c8873b2281033878a4acb Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 2 Feb 2023 14:43:58 -0500 Subject: tests: pack: Fix indentation. * tests/pack.scm: Fix indentation. --- tests/pack.scm | 279 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 137 insertions(+), 142 deletions(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index a4c388d93e..a02924b7d2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -74,44 +74,43 @@ -> "bin/guile")) #:compressor %gzip-compressor #:archiver %tar-bootstrap)) - (check (gexp->derivation - "check-tarball" - (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"))))))))) + (check (gexp->derivation "check-tarball" + (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 @@ -131,17 +130,16 @@ #: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)))))))) + (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)) @@ -154,45 +152,44 @@ ("λ" regular (data "lambda"))))) (tarball (self-contained-tarball "tar-pack" tree #:localstatedir? #t)) - (check (gexp->derivation - "check-tarball" - (with-extensions (list guile-sqlite3 guile-gcrypt) - (with-imported-modules (source-module-closure - '((guix store database))) - #~(begin - (use-modules (guix store database) - (rnrs io ports) - (srfi srfi-1)) - - (define (valid-file? basename data) - (define file - (string-append "./" #$tree "/" basename)) - - (string=? (call-with-input-file (pk 'file file) - get-string-all) - data)) - - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - - (sql-schema - #$(local-file (search-path %load-path - "guix/store/schema.sql"))) - (with-database "var/guix/db/db.sqlite" db - ;; Make sure non-ASCII file names are properly - ;; handled. - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales - "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - (mkdir #$output) - (exit - (and (every valid-file? - '("α" "λ") - '("alpha" "lambda")) - (integer? (path-id db #$tree))))))))))) + (check (gexp->derivation "check-tarball" + (with-extensions (list guile-sqlite3 guile-gcrypt) + (with-imported-modules (source-module-closure + '((guix store database))) + #~(begin + (use-modules (guix store database) + (rnrs io ports) + (srfi srfi-1)) + + (define (valid-file? basename data) + (define file + (string-append "./" #$tree "/" basename)) + + (string=? (call-with-input-file (pk 'file file) + get-string-all) + data)) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + + (sql-schema + #$(local-file (search-path %load-path + "guix/store/schema.sql"))) + (with-database "var/guix/db/db.sqlite" db + ;; Make sure non-ASCII file names are properly + ;; handled. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales + "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (mkdir #$output) + (exit + (and (every valid-file? + '("α" "λ") + '("alpha" "lambda")) + (integer? (path-id db #$tree))))))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -206,34 +203,33 @@ (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") - (file-is-directory? "tmp") - (string=? (string-append #$%bootstrap-guile "/bin") - (pk 'binlink (readlink bin))) - (string=? (string-append #$profile "/bin/guile") - (pk 'guilelink (readlink "bin/Guile")))) - (mkdir #$output))))))) + (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") + (file-is-directory? "tmp") + (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)))) (unless store (test-skip 1)) @@ -247,32 +243,31 @@ (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 "/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))) - - ;; This is a relative symlink target. - (string=? (string-drop - (string-append #$profile "/bin") - 1) - (pk 'guilelink (readlink "bin")))) - (mkdir #$output)))))))) + (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 "/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))) + + ;; This is a relative symlink target. + (string=? (string-drop + (string-append #$profile "/bin") + 1) + (pk 'guilelink (readlink "bin")))) + (mkdir #$output)))))))) (built-derivations (list check)))) (unless store (test-skip 1)) -- cgit v1.2.3 From 598f4c509bbfec2b983a8ee246cce0a0fe45ec7f Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 21 Jan 2023 15:04:09 -0500 Subject: pack: Add RPM format. * guix/rpm.scm: New file. * guix/scripts/pack.scm (rpm-archive): New procedure. (%formats): Register it. (show-formats): Add it. (guix-pack): Register supported extra-options for the rpm format. * tests/pack.scm (rpm-for-tests): New variable. ("rpm archive can be installed/uninstalled"): New test. * tests/rpm.scm: New test. * doc/guix.texi (Invoking guix pack): Document it. --- Makefile.am | 2 + doc/guix.texi | 46 +++- guix/rpm.scm | 623 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pack.scm | 230 ++++++++++++++++++- tests/pack.scm | 57 ++++- tests/rpm.scm | 86 +++++++ 6 files changed, 1031 insertions(+), 13 deletions(-) create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 5ce6cc84f4..8e3815b9c2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -111,6 +111,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/rpm.scm \ guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ @@ -535,6 +536,7 @@ SCM_TESTS = \ tests/pypi.scm \ tests/read-print.scm \ tests/records.scm \ + tests/rpm.scm \ tests/scripts.scm \ tests/search-paths.scm \ tests/services.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 44e2165a82..05615b9549 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6896,6 +6896,7 @@ such file or directory'' message. @end quotation @item deb +@cindex Debian, build a .deb package with guix pack This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. @@ -6912,7 +6913,8 @@ guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello Because archives produced with @command{guix pack} contain a collection of store items and because each @command{dpkg} package must not have conflicting files, in practice that means you likely won't be able to -install more than one such archive on a given system. +install more than one such archive on a given system. You can +nonetheless pack as many Guix packages as you want in one such archive. @end quotation @quotation Warning @@ -6923,6 +6925,48 @@ shared by other software, such as a Guix installation or other, non-deb packs. @end quotation +@item rpm +@cindex RPM, build an RPM archive with guix pack +This produces an RPM archive (a package with the @samp{.rpm} file +extension) containing all the specified binaries and symbolic links, +that can be installed on top of any RPM-based GNU/Linux distribution. +The RPM format embeds checksums for every file it contains, which the +@command{rpm} command uses to validate the integrity of the archive. + +Advanced RPM-related options are revealed via the +@option{--help-rpm-format} option. These options allow embedding +maintainer scripts that can run before or after the installation of the +RPM archive, for example. + +The RPM format supports relocatable packages via the @option{--prefix} +option of the @command{rpm} command, which can be handy to install an +RPM package to a specific prefix. + +@example +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello +@end example + +@example +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm +@end example + +@quotation Note +Contrary to Debian packages, conflicting but @emph{identical} files in +RPM packages can be installed simultaneously, which means multiple +@command{guix pack}-produced RPM packages can usually be installed side +by side without any problem. +@end quotation + +@quotation Warning +@command{rpm} assumes ownership of any files contained in the pack, +which means it will remove @file{/gnu/store} upon uninstalling a +Guix-generated RPM package, unless the RPM package was installed with +the @option{--prefix} option of the @command{rpm} command. It is unwise +to install Guix-produced @samp{.rpm} packages on a system where +@file{/gnu/store} is shared by other software, such as a Guix +installation or other, non-rpm packs. +@end quotation + @end table @cindex relocatable binaries diff --git a/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..1cb8326a9b --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,623 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer +;;; +;;; 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 rpm) + #:autoload (gcrypt hash) (hash-algorithm file-hash md5) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-171) + #:export (generate-lead + generate-signature + generate-header + assemble-rpm-metadata + + ;; XXX: These are internals, but the inline disabling trick + ;; doesn't work on them. + make-header-entry + header-entry? + header-entry-tag + header-entry-count + header-entry-value + + bytevector->hex-string + + fhs-directory?)) + +;;; Commentary: +;;; +;;; This module provides the building blocks required to construct RPM +;;; archives. It is intended to be importable on the build side, so shouldn't +;;; depend on (guix diagnostics) or other host-side-only modules. +;;; +;;; Code: + +(define (gnu-system-triplet->machine-type triplet) + "Return the machine component of TRIPLET, a GNU system triplet." + (first (string-split triplet #\-))) + +(define (gnu-machine-type->rpm-arch type) + "Return the canonical RPM architecture string, given machine TYPE." + (match type + ("arm" "armv7hl") + ("powerpc" "ppc") + ("powerpc64le" "ppc64le") + (machine machine))) ;unchanged + +(define (gnu-machine-type->rpm-number type) + "Translate machine TYPE to its corresponding RPM integer value." + ;; Refer to the rpmrc.in file in the RPM source for the complete + ;; translation tables. + (match type + ((or "i486" "i586" "i686" "x86_64") 1) + ((? (cut string-prefix? "powerpc" <>)) 5) + ("mips64el" 11) + ((? (cut string-prefix? "arm" <>)) 12) + ("aarch64" 19) + ((? (cut string-prefix? "riscv" <>)) 22) + (_ (error "no RPM number known for machine type" type)))) + +(define (u16-number->u8-list number) + "Return a list of byte values made of NUMBER, a 16 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 2))) + (bytevector->u8-list bv))) + +(define (u32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (s32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit signed integer." + (let ((bv (sint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (u8-list->u32-number lst) + "Return the 32 bit unsigned integer corresponding to the 4 bytes in LST." + (bytevector-u32-ref (u8-list->bytevector lst) 0 (endianness big))) + + +;;; +;;; Lead section. +;;; + +;; Refer to the docs/manual/format.md file of the RPM source for the details +;; regarding the binary format of an RPM archive. +(define* (generate-lead name-version #:key (target %host-type)) + "Generate a RPM lead u8-list that uses NAME-VERSION, the name and version +string of the package, and TARGET, a GNU triplet used to derive the target +machine type." + (define machine-type (gnu-system-triplet->machine-type target)) + (define magic (list #xed #xab #xee #xdb)) + (define file-format-version (list 3 0)) ;3.0 + (define type (list 0 0)) ;0 for binary packages + (define arch-number (u16-number->u8-list + (gnu-machine-type->rpm-number machine-type))) + ;; The 66 bytes from 10 to 75 are for the name-version-release string. + (define name + (let ((padding-bytes (make-list (- 66 (string-length name-version)) 0))) + (append (bytevector->u8-list (string->utf8 name-version)) + padding-bytes))) + ;; There is no OS number corresponding to GNU/Hurd (GNU), only Linux, per + ;; rpmrc.in. + (define os-number (list 0 1)) + + ;; For RPM format 3.0, the signature type is 5, which means a "Header-style" + ;; signature. + (define signature-type (list 0 5)) + + (define reserved-bytes (make-list 16 0)) + + (append magic file-format-version type arch-number name + os-number signature-type reserved-bytes)) + + +;;; +;;; Header section. +;;; + +(define header-magic (list #x8e #xad #xe8)) +(define header-version (list 1)) +(define header-reserved (make-list 4 0)) ;4 reserved bytes +;;; Every header starts with 8 bytes made by the header magic number, the +;;; header version and 4 reserved bytes. +(define header-intro (append header-magic header-version header-reserved)) + +;;; Header entry data types. +(define NULL 0) +(define CHAR 1) +(define INT8 2) +(define INT16 3) ;2-bytes aligned +(define INT32 4) ;4-bytes aligned +(define INT64 5) ;8-bytes aligned +(define STRING 6) +(define BIN 7) +(define STRING_ARRAY 8) +(define I18NSTRIN_TYPE 9) + +;;; Header entry tags. +(define-record-type + (make-rpm-tag number type) + rpm-tag? + (number rpm-tag-number) + (type rpm-tag-type)) + +;;; The following are internal tags used to identify the data sections. +(define RPMTAG_HEADERSIGNATURES (make-rpm-tag 62 BIN)) ;signature header +(define RPMTAG_HEADERIMMUTABLE (make-rpm-tag 63 BIN)) ;main/data header +(define RPMTAG_HEADERI18NTABLE (make-rpm-tag 100 STRING_ARRAY)) + +;;; Subset of RPM tags from include/rpm/rpmtag.h. +(define RPMTAG_NAME (make-rpm-tag 1000 STRING)) +(define RPMTAG_VERSION (make-rpm-tag 1001 STRING)) +(define RPMTAG_RELEASE (make-rpm-tag 1002 STRING)) +(define RPMTAG_SUMMARY (make-rpm-tag 1004 STRING)) +(define RPMTAG_SIZE (make-rpm-tag 1009 INT32)) +(define RPMTAG_LICENSE (make-rpm-tag 1014 STRING)) +(define RPMTAG_OS (make-rpm-tag 1021 STRING)) +(define RPMTAG_ARCH (make-rpm-tag 1022 STRING)) +(define RPMTAG_PREIN (make-rpm-tag 1023 STRING)) +(define RPMTAG_POSTIN (make-rpm-tag 1024 STRING)) +(define RPMTAG_PREUN (make-rpm-tag 1025 STRING)) +(define RPMTAG_POSTUN (make-rpm-tag 1026 STRING)) +(define RPMTAG_FILESIZES (make-rpm-tag 1028 INT32)) +(define RPMTAG_FILEMODES (make-rpm-tag 1030 INT16)) +(define RPMTAG_FILEDIGESTS (make-rpm-tag 1035 STRING_ARRAY)) +(define RPMTAG_FILELINKTOS (make-rpm-tag 1036 STRING_ARRAY)) +(define RPMTAG_FILEUSERNAME (make-rpm-tag 1039 STRING_ARRAY)) +(define RPMTAG_GROUPNAME (make-rpm-tag 1040 STRING_ARRAY)) +(define RPMTAG_PREFIXES (make-rpm-tag 1098 STRING_ARRAY)) +(define RPMTAG_DIRINDEXES (make-rpm-tag 1116 INT32)) +(define RPMTAG_BASENAMES (make-rpm-tag 1117 STRING_ARRAY)) +(define RPMTAG_DIRNAMES (make-rpm-tag 1118 STRING_ARRAY)) +(define RPMTAG_PAYLOADFORMAT (make-rpm-tag 1124 STRING)) +(define RPMTAG_PAYLOADCOMPRESSOR (make-rpm-tag 1125 STRING)) +(define RPMTAG_LONGFILESIZES (make-rpm-tag 5008 INT64)) +(define RPMTAG_LONGSIZE (make-rpm-tag 5009 INT64)) +;;; The algorithm used to compute the digest of each file, e.g. RPM_HASH_MD5. +(define RPMTAG_FILEDIGESTALGO (make-rpm-tag 5011 INT32)) +;;; RPMTAG_ENCODING specifies the encoding used for strings, e.g. "utf-8". +(define RPMTAG_ENCODING (make-rpm-tag 5062 STRING)) +;;; Compressed payload digest. Its type is a string array, but currently in +;;; practice it is equivalent to STRING, since only the first element is used. +(define RPMTAG_PAYLOADDIGEST (make-rpm-tag 5092 STRING_ARRAY)) +;;; The algorithm used to compute the payload digest, e.g. RPM_HASH_SHA256. +(define RPMTAG_PAYLOADDIGESTALGO (make-rpm-tag 5093 INT32)) +;;; The following are taken from the rpmHashAlgo_e enum in rpmcrypto.h. +(define RPM_HASH_MD5 1) +(define RPM_HASH_SHA256 8) + +;;; Other useful internal definitions. +(define REGION_TAG_COUNT 16) ;number of bytes +(define INT32_MAX (1- (expt 2 32))) ;4294967295 bytes (unsigned) + +(define (rpm-tag->u8-list tag) + "Return the u8 list corresponding to RPM-TAG, a object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type + (make-header-entry tag count value) + header-entry? + (tag header-entry-tag) ; + (count header-entry-count) ;number (u32) + (value header-entry-value)) ;string|number|list|... + +(define (entry-type->alignement type) + "Return the byte alignment of TYPE, an RPM header entry type." + (cond ((= INT16 type) 2) + ((= INT32 type) 4) + ((= INT64 type) 8) + (else 1))) + +(define (next-aligned-offset offset alignment) + "Return the next position from OFFSET which satisfies ALIGNMENT." + (if (= 0 (modulo offset alignment)) + offset + (next-aligned-offset (1+ offset) alignment))) + +(define (header-entry->data entry) + "Return the data of ENTRY, a object, as a u8 list." + (let* ((tag (header-entry-tag entry)) + (count (header-entry-count entry)) + (value (header-entry-value entry)) + (number (rpm-tag-number tag)) + (type (rpm-tag-type tag))) + (cond + ((= STRING type) + (unless (string? value) + (error "expected string value for STRING type, got" value)) + (unless (= 1 count) + (error "count must be 1 for STRING type")) + (let ((value (cond ((= (rpm-tag-number RPMTAG_VERSION) number) + ;; Hyphens are not allowed in version strings. + (string-map (match-lambda + (#\- #\+) + (c c)) + value)) + (else value)))) + (append (bytevector->u8-list (string->utf8 value)) + (list 0)))) ;strings must end with null byte + ((= STRING_ARRAY type) + (unless (list? value) + (error "expected a list of strings for STRING_ARRAY type, got" value)) + (unless (= count (length value)) + (error "expected count to be equal to" (length value) 'got count)) + (append-map (lambda (s) + (append (bytevector->u8-list (string->utf8 s)) + (list 0))) ;null byte separated + value)) + ((member type (list INT8 INT16 INT32)) + (if (= 1 count) + (unless (number? value) + (error "expected number value for scalar INT type; got" value)) + (unless (list? value) + (error "expected list value for array INT type; got" value))) + (if (list? value) + (cond ((= INT8 type) value) + ((= INT16 type) (append-map u16-number->u8-list value)) + ((= INT32 type) (append-map u32-number->u8-list value)) + (else (error "unexpected type" type))) + (cond ((= INT8 type) (list value)) + ((= INT16 type) (u16-number->u8-list value)) + ((= INT32 type) (u32-number->u8-list value)) + (else (error "unexpected type" type))))) + ((= BIN type) + (unless (list? value) + (error "expected list value for BIN type; got" value)) + value) + (else (error "unimplemented type" type))))) + +(define (make-header-index+data entries) + "Return the index and data sections as u8 number lists, via multiple values. +An index is composed of four u32 (16 bytes total) quantities, in order: tag, +type, offset and count." + (match (fold (match-lambda* + ((entry (offset . (index . data))) + (let* ((tag (header-entry-tag entry)) + (tag-number (rpm-tag-number tag)) + (tag-type (rpm-tag-type tag)) + (count (header-entry-count entry)) + (data* (header-entry->data entry)) + (alignment (entry-type->alignement tag-type)) + (aligned-offset (next-aligned-offset offset alignment)) + (padding (make-list (- aligned-offset offset) 0))) + (cons (+ aligned-offset (length data*)) + (cons (append index + (u32-number->u8-list tag-number) + (u32-number->u8-list tag-type) + (u32-number->u8-list aligned-offset) + (u32-number->u8-list count)) + (append data padding data*)))))) + '(0 . (() . ())) + entries) + ((offset . (index . data)) + (values index data)))) + +;; Prevent inlining of the variables/procedures accessed by unit tests. +(set! make-header-index+data make-header-index+data) +(set! RPMTAG_ARCH RPMTAG_ARCH) +(set! RPMTAG_LICENSE RPMTAG_LICENSE) +(set! RPMTAG_NAME RPMTAG_NAME) +(set! RPMTAG_OS RPMTAG_OS) +(set! RPMTAG_RELEASE RPMTAG_RELEASE) +(set! RPMTAG_SUMMARY RPMTAG_SUMMARY) +(set! RPMTAG_VERSION RPMTAG_VERSION) + +(define (wrap-in-region-tags header region-tag) + "Wrap HEADER, a header provided as u8-list with REGION-TAG." + (let* ((type (rpm-tag-type region-tag)) + (header-intro (take header 16)) + (header-rest (drop header 16)) + ;; Increment the existing index value to account for the added region + ;; tag index. + (index-length (1+ (u8-list->u32-number + (drop-right (drop header-intro 8) 4)))) ;bytes 8-11 + ;; Increment the data length value to account for the added region + ;; tag data. + (data-length (+ REGION_TAG_COUNT + (u8-list->u32-number + (take-right header-intro 4))))) ;last 4 bytes of intro + (unless (member region-tag (list RPMTAG_HEADERSIGNATURES + RPMTAG_HEADERIMMUTABLE)) + (error "expected RPMTAG_HEADERSIGNATURES or RPMTAG_HEADERIMMUTABLE, got" + region-tag)) + (append (drop-right header-intro 8) ;strip existing index and data lengths + (u32-number->u8-list index-length) + (u32-number->u8-list data-length) + ;; Region tag (16 bytes). + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (u32-number->u8-list (- data-length REGION_TAG_COUNT)) ;offset + (u32-number->u8-list REGION_TAG_COUNT) ;count + ;; Immutable region. + header-rest + ;; Region tag trailer (16 bytes). Note: the trailer offset value + ;; is an enforced convention; it has no practical use. + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (s32-number->u8-list (* -1 index-length 16)) ;negative offset + (u32-number->u8-list REGION_TAG_COUNT)))) ;count + +(define (bytevector->hex-string bv) + (format #f "~{~2,'0x~}" (bytevector->u8-list bv))) + +(define (files->md5-checksums files) + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." + (let ((file-md5 (cut file-hash (hash-algorithm md5) <>))) + (map (lambda (f) + (or (and=> (false-if-exception (file-md5 f)) + bytevector->hex-string) + ;; Only regular files (e.g., not directories) can have their + ;; checksum computed. + "")) + files))) + +(define (strip-leading-dot name) + "Remove the leading \".\" from NAME, if present. If a single \".\" is +encountered, translate it to \"/\"." + (match name + ("." "/") ;special case + ((? (cut string-prefix? "." <>)) + (string-drop name 1)) + (x name))) + +;;; An extensive list of required and optional FHS directories, per its 3.0 +;;; revision. +(define %fhs-directories + (list "/bin" "/boot" "/dev" + "/etc" "/etc/opt" "/etc/X11" "/etc/sgml" "/etc/xml" + "/home" "/root" "/lib" "/media" "/mnt" + "/opt" "/opt/bin" "/opt/doc" "/opt/include" + "/opt/info" "/opt/lib" "/opt/man" + "/run" "/sbin" "/srv" "/sys" "/tmp" + "/usr" "/usr/bin" "/usr/include" "/usr/libexec" + "/usr/share/color" "/usr/share/dict" "/usr/share/doc" "/usr/share/games" + "/usr/share/info" "/usr/share/locale" "/usr/share/man" "/usr/share/misc" + "/usr/share/nls" "/usr/share/ppd" "/usr/share/sgml" + "/usr/share/terminfo" "/usr/share/tmac" "/usr/share/xml" + "/usr/share/zoneinfo" "/usr/local" "/usr/local/bin" "/usr/local/etc" + "/usr/local/games" "/usr/local/include" "/usr/local/lib" + "/usr/local/man" "/usr/local/sbin" "/usr/local/sbin" "/usr/local/share" + "/usr/local/src" "/var" "/var/account" "/var/backups" + "/var/cache" "/var/cache/fonts" "/var/cache/man" "/var/cache/www" + "/var/crash" "/var/cron" "/var/games" "/var/mail" "/var/msgs" + "/var/lib" "/var/lib/color" "/var/lib/hwclock" "/var/lib/misc" + "/var/local" "/var/lock" "/var/log" "/var/opt" "/var/preserve" + "/var/run" "/var/spool" "/var/spool/lpd" "/var/spool/mqueue" + "/var/spool/news" "/var/spool/rwho" "/var/spool/uucp" + "/var/tmp" "/var/yp")) + +(define (fhs-directory? file-name) + "Predicate to check if FILE-NAME is a known File Hierarchy Standard (FHS) +directory." + (member (strip-leading-dot file-name) %fhs-directories)) + +(define (directory->file-entries directory) + "Return the file lists triplet header entries for the files found under +DIRECTORY." + (with-directory-excursion directory + ;; Skip the initial "." directory, as its name would get concatenated with + ;; the "./" dirname and fail to match "." in the payload. + (let* ((files (cdr (find-files "." #:directories? #t))) + (file-stats (map lstat files)) + (directories + (append (list ".") + (filter-map (match-lambda + ((index . file) + (let ((st (list-ref file-stats index))) + (and (eq? 'directory (stat:type st)) + file)))) + (list-transduce (tenumerate) rcons files)))) + ;; Omit any FHS directories found in FILES to avoid the RPM package + ;; from owning them. This can occur when symlinks directives such + ;; as "/usr/bin/hello -> bin/hello" are used. + (package-files package-file-stats + (unzip2 (reverse + (fold (lambda (file stat res) + (if (fhs-directory? file) + res + (cons (list file stat) res))) + '() files file-stats)))) + + ;; When provided with the index of a file, the directory index must + ;; return the index of the corresponding directory entry. + (dirindexes (map (lambda (d) + (list-index (cut string=? <> d) directories)) + (map dirname package-files))) + ;; The files owned are those appearing in 'basenames'; own them + ;; all. + (basenames (map basename package-files)) + ;; The directory names must end with a trailing "/". + (dirnames (map (compose strip-leading-dot (cut string-append <> "/")) + directories)) + ;; Note: All the file-related entries must have the same length as + ;; the basenames entry. + (symlink-targets (map (lambda (f) + (if (symbolic-link? f) + (readlink f) + "")) ;unused + package-files)) + (file-modes (map stat:mode package-file-stats)) + (file-sizes (map stat:size package-file-stats)) + (file-md5s (files->md5-checksums package-files))) + (let ((basenames-length (length basenames)) + (dirindexes-length (length dirindexes))) + (unless (= basenames-length dirindexes-length) + (error "length mismatch for dirIndexes; expected/actual" + basenames-length dirindexes-length)) + (append + (if (> (apply max file-sizes) INT32_MAX) + (list (make-header-entry RPMTAG_LONGFILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_LONGSIZE 1 + (reduce + 0 file-sizes))) + (list (make-header-entry RPMTAG_FILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_SIZE 1 (reduce + 0 file-sizes)))) + (list + (make-header-entry RPMTAG_FILEMODES (length file-modes) file-modes) + (make-header-entry RPMTAG_FILEDIGESTS (length file-md5s) file-md5s) + (make-header-entry RPMTAG_FILEDIGESTALGO 1 RPM_HASH_MD5) + (make-header-entry RPMTAG_FILELINKTOS (length symlink-targets) + symlink-targets) + (make-header-entry RPMTAG_FILEUSERNAME basenames-length + (make-list basenames-length "root")) + (make-header-entry RPMTAG_GROUPNAME basenames-length + (make-list basenames-length "root")) + ;; The dirindexes, basenames and dirnames tags form the so-called RPM + ;; "path triplet". + (make-header-entry RPMTAG_DIRINDEXES dirindexes-length dirindexes) + (make-header-entry RPMTAG_BASENAMES basenames-length basenames) + (make-header-entry RPMTAG_DIRNAMES (length dirnames) dirnames))))))) + +(define (make-header entries) + "Return the u8 list of a RPM header containing ENTRIES, a list of + objects." + (let* ((entries (sort entries (lambda (x y) + (< (rpm-tag-number (header-entry-tag x)) + (rpm-tag-number (header-entry-tag y)))))) + (count (length entries)) + (index data (make-header-index+data entries))) + (append header-intro ;8 bytes + (u32-number->u8-list count) ;4 bytes + (u32-number->u8-list (length data)) ;4 bytes + ;; Now starts the header index, which can contain up to 32 entries + ;; of 16 bytes each. + index data))) + +(define* (generate-header name version + payload-digest + payload-directory + payload-compressor + #:key + relocatable? + prein-file postin-file + preun-file postun-file + (target %host-type) + (release "0") + (license "N/A") + (summary "RPM archive generated by GNU Guix.") + (os "Linux")) ;see rpmrc.in + "Return the u8 list corresponding to the Header section. PAYLOAD-DIGEST is +the SHA256 checksum string of the compressed payload. PAYLOAD-DIRECTORY is +the directory containing the payload files. PAYLOAD-COMPRESSOR is the name of +the compressor used to compress the CPIO payload, such as \"none\", \"gz\", +\"xz\" or \"zstd\"." + (let* ((rpm-arch (gnu-machine-type->rpm-arch + (gnu-system-triplet->machine-type target))) + (file->string (cut call-with-input-file <> get-string-all)) + (prein-script (and=> prein-file file->string)) + (postin-script (and=> postin-file file->string)) + (preun-script (and=> preun-file file->string)) + (postun-script (and=> postun-file file->string))) + (wrap-in-region-tags + (make-header (append + (list (make-header-entry RPMTAG_HEADERI18NTABLE 1 (list "C")) + (make-header-entry RPMTAG_NAME 1 name) + (make-header-entry RPMTAG_VERSION 1 version) + (make-header-entry RPMTAG_RELEASE 1 release) + (make-header-entry RPMTAG_SUMMARY 1 summary) + (make-header-entry RPMTAG_LICENSE 1 license) + (make-header-entry RPMTAG_OS 1 os) + (make-header-entry RPMTAG_ARCH 1 rpm-arch)) + (directory->file-entries payload-directory) + (if relocatable? + ;; Note: RPMTAG_PREFIXES must not have a trailing + ;; slash, unless it's '/'. This allows installing the + ;; package via 'rpm -i --prefix=/tmp', for example. + (list (make-header-entry RPMTAG_PREFIXES 1 (list "/"))) + '()) + (if prein-script + (list (make-header-entry RPMTAG_PREIN 1 prein-script)) + '()) + (if postin-script + (list (make-header-entry RPMTAG_POSTIN 1 postin-script)) + '()) + (if preun-script + (list (make-header-entry RPMTAG_PREUN 1 preun-script)) + '()) + (if postun-script + (list (make-header-entry RPMTAG_POSTUN 1 postun-script)) + '()) + (if (string=? "none" payload-compressor) + '() + (list (make-header-entry RPMTAG_PAYLOADCOMPRESSOR 1 + payload-compressor))) + (list (make-header-entry RPMTAG_ENCODING 1 "utf-8") + (make-header-entry RPMTAG_PAYLOADFORMAT 1 "cpio") + (make-header-entry RPMTAG_PAYLOADDIGEST 1 + (list payload-digest)) + (make-header-entry RPMTAG_PAYLOADDIGESTALGO 1 + RPM_HASH_SHA256)))) + RPMTAG_HEADERIMMUTABLE))) + + +;;; +;;; Signature section +;;; + +;;; Header sha256 checksum. +(define RPMSIGTAG_SHA256 (make-rpm-tag 273 STRING)) +;;; Uncompressed payload size. +(define RPMSIGTAG_PAYLOADSIZE (make-rpm-tag 1007 INT32)) +;;; Header and compressed payload combined size. +(define RPMSIGTAG_SIZE (make-rpm-tag 1000 INT32)) +;;; Uncompressed payload size (when size > max u32). +(define RPMSIGTAG_LONGARCHIVESIZE (make-rpm-tag 271 INT64)) +;;; Header and compressed payload combined size (when size > max u32). +(define RPMSIGTAG_LONGSIZE (make-rpm-tag 270 INT64)) +;;; Extra space reserved for signatures (typically 32 bytes). +(define RPMSIGTAG_RESERVEDSPACE (make-rpm-tag 1008 BIN)) + +(define (generate-signature header-sha256 + header+compressed-payload-size + ;; uncompressed-payload-size + ) + "Return the u8 list representing a signature header containing the +HEADER-SHA256 (a string) and the PAYLOAD-SIZE, which is the combined size of +the header and compressed payload." + (define size-tag (if (> header+compressed-payload-size INT32_MAX) + RPMSIGTAG_LONGSIZE + RPMSIGTAG_SIZE)) + (wrap-in-region-tags + (make-header (list (make-header-entry RPMSIGTAG_SHA256 1 header-sha256) + (make-header-entry size-tag 1 + header+compressed-payload-size) + ;; (make-header-entry RPMSIGTAG_PAYLOADSIZE 1 + ;; uncompressed-payload-size) + ;; Reserve 32 bytes of extra space in case users would + ;; like to add signatures, as done in rpmGenerateSignature. + (make-header-entry RPMSIGTAG_RESERVEDSPACE 32 + (make-list 32 0)))) + RPMTAG_HEADERSIGNATURES)) + +(define (assemble-rpm-metadata lead signature header) + "Align and append the various u8 list components together, and return the +result as a bytevector." + (let* ((offset (+ (length lead) (length signature))) + (header-offset (next-aligned-offset offset 8)) + (padding (make-list (- header-offset offset) 0))) + ;; The Header is 8-bytes aligned. + (u8-list->bytevector (append lead signature padding header)))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 77425e5b0f..701e41ff1a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2018 Chris Marusich ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer ;;; Copyright © 2020 Eric Bavier ;;; Copyright © 2022 Alex Griffin ;;; @@ -67,6 +67,7 @@ self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -856,6 +857,166 @@ Section: misc ;;; +;;; RPM archive format. +;;; +(define* (rpm-archive name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (first %compressors)) + deduplicate? + localstatedir? + (symlinks '()) + archiver + (extra-options '())) + "Return a RPM archive (.rpm) containing a store initialized with the closure +of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be +a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack. +ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE, +PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (define payload + (let* ((raw-cpio-file-name "payload.cpio") + (compressed-cpio-file-name (string-append raw-cpio-file-name + (compressor-extension + compressor)))) + (computed-file compressed-cpio-file-name + (with-imported-modules (source-module-closure + '((guix build utils) + (guix cpio) + (guix rpm))) + #~(begin + (use-modules (guix build utils) + (guix cpio) + (guix rpm) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define %root (if #$localstatedir? "." #$root)) + + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion %root + ;; The first "." entry is discarded. + (write-cpio-archive + (remove fhs-directory? + (cdr (find-files "." #:directories? #t))) + port)))) + (when #+(compressor-command compressor) + (apply invoke (append #+(compressor-command compressor) + (list #$raw-cpio-file-name)))) + (copy-file #$compressed-cpio-file-name #$output))) + #:local-build? #f))) ;allow offloading + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm)) + #:select? not-config?)) + #~(begin + (use-modules (gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm) + (ice-9 binary-ports) + (ice-9 match) ;for manifest->friendly-name + (ice-9 optargs) + (rnrs bytevectors) + (srfi srfi-1)) + + (define machine-type + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (_ #f))) + + (define name + (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define version + (or (and=> single-entry manifest-entry-version) "0.0.0")) + + (define lead + (generate-lead (string-append name "-" version) + #:target (or #$target %host-type))) + + (define payload-digest + (bytevector->hex-string (file-sha256 #$payload))) + + (let-keywords '#$extra-options #f ((relocatable? #f) + (prein-file #f) + (postin-file #f) + (preun-file #f) + (postun-file #f)) + + (let ((header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? relocatable? + #:prein-file prein-file + #:postin-file postin-file + #:preun-file preun-file + #:postun-file postun-file))) + + (define header-sha256 + (bytevector->hex-string (sha256 (u8-list->bytevector header)))) + + (define payload-size (stat:size (stat #$payload))) + + (define header+compressed-payload-size + (+ (length header) payload-size)) + + (define signature + (generate-signature header-sha256 + header+compressed-payload-size)) + + ;; Serialize the archive components to a file. + (call-with-input-file #$payload + (lambda (in) + (call-with-output-file #$output + (lambda (out) + (put-bytevector out (assemble-rpm-metadata lead + signature + header)) + (sendfile out in payload-size))))))))))) + + (gexp->derivation (string-append name ".rpm") build)) + + +;;; ;;; Compiling C programs. ;;; @@ -1187,7 +1348,8 @@ last resort for relocation." `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) - (deb . ,debian-archive))) + (deb . ,debian-archive) + (rpm . ,rpm-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -1201,18 +1363,22 @@ last resort for relocation." docker Tarball ready for 'docker load'")) (display (G_ " deb Debian archive installable via dpkg/apt")) + (display (G_ " + rpm RPM archive installable via rpm/yum")) (newline)) +(define (required-option symbol) + "Return an SYMBOL option that requires a value." + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))) + (define %deb-format-options - (let ((required-option (lambda (symbol) - (option (list (symbol->string symbol)) #t #f - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest)))))) - (list (required-option 'control-file) - (required-option 'postinst-file) - (required-option 'triggers-file)))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file))) (define (show-deb-format-options) (display (G_ " @@ -1231,6 +1397,32 @@ last resort for relocation." (newline) (exit 0)) +(define %rpm-format-options + (list (required-option 'prein-file) + (required-option 'postin-file) + (required-option 'preun-file) + (required-option 'postun-file))) + +(define (show-rpm-format-options) + (display (G_ " + --help-rpm-format list options specific to the RPM format"))) + +(define (show-rpm-format-options/detailed) + (display (G_ " + --prein-file=FILE + Embed the provided prein script")) + (display (G_ " + --postin-file=FILE + Embed the provided postin script")) + (display (G_ " + --preun-file=FILE + Embed the provided preun script")) + (display (G_ " + --postun-file=FILE + Embed the provided postun script")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1307,7 +1499,12 @@ last resort for relocation." (lambda args (show-deb-format-options/detailed))) + (option '("help-rpm-format") #f #f + (lambda args + (show-rpm-format-options/detailed))) + (append %deb-format-options + %rpm-format-options %transformation-options %standard-build-options %standard-cross-build-options @@ -1325,6 +1522,7 @@ Create a bundle of PACKAGE.\n")) (show-transformation-options-help) (newline) (show-deb-format-options) + (show-rpm-format-options) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) @@ -1483,6 +1681,16 @@ Create a bundle of PACKAGE.\n")) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable? + #:prein-file + (process-file-arg opts 'prein-file) + #:postin-file + (process-file-arg opts 'postin-file) + #:preun-file + (process-file-arg opts 'preun-file) + #:postun-file + (process-file-arg opts 'postun-file))) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/tests/pack.scm b/tests/pack.scm index a02924b7d2..734ae1c69b 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus -;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2021, 2023 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,13 +28,16 @@ #:use-module (guix tests) #:use-module (guix gexp) #:use-module (guix modules) + #:use-module (guix utils) #:use-module (gnu packages) #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages package-management) #:select (rpm)) #:use-module ((gnu packages compression) #:select (squashfs-tools)) #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages linux) #:select (fakeroot)) #:use-module (srfi srfi-64)) (define %store @@ -59,6 +62,17 @@ (define %ar-bootstrap %bootstrap-binutils) +;;; This is a variant of the RPM package configured so that its database can +;;; be created on a writable location readily available inside the build +;;; container ("/tmp"). +(define rpm-for-tests + (package + (inherit rpm) + (arguments (substitute-keyword-arguments (package-arguments rpm) + ((#:configure-flags flags '()) + #~(cons "--localstatedir=/tmp" + (delete "--localstatedir=/var" #$flags))))))) + (test-begin "pack") @@ -355,6 +369,47 @@ (stat "postinst")))))) (assert (file-exists? "triggers")) + (mkdir #$output)))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "rpm archive can be installed/uninstalled" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (rpm-pack (rpm-archive "rpm-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/bin/guile" -> "bin/guile")) + #:extra-options '(#:relocatable? #t))) + (check + (gexp->derivation "check-rpm-pack" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install the RPM package. This causes RPM to validate the + ;; signatures, header as well as the file digests, which + ;; makes it a rather thorough test. + (mkdir "test-prefix") + (invoke fakeroot rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; Invoke the installed Guile command. + (invoke "./test-prefix/bin/guile" "--version") + + ;; Uninstall the RPM package. + (invoke fakeroot rpm "--erase" "guile-bootstrap") + + ;; Required so the above is run. (mkdir #$output)))))) (built-derivations (list check))))) diff --git a/tests/rpm.scm b/tests/rpm.scm new file mode 100644 index 0000000000..f40b36fe60 --- /dev/null +++ b/tests/rpm.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer +;;; +;;; 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-rpm) + #:use-module (guix rpm) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71)) + +;; For white-box testing. +(define-syntax-rule (expose-internal name) + (define name (@@ (guix rpm) name))) + +(expose-internal RPMTAG_ARCH) +(expose-internal RPMTAG_LICENSE) +(expose-internal RPMTAG_NAME) +(expose-internal RPMTAG_OS) +(expose-internal RPMTAG_RELEASE) +(expose-internal RPMTAG_SUMMARY) +(expose-internal RPMTAG_VERSION) +(expose-internal header-entry-count) +(expose-internal header-entry-tag) +(expose-internal header-entry-value) +(expose-internal header-entry?) +(expose-internal make-header) +(expose-internal make-header-entry) +(expose-internal make-header-index+data) + +(test-begin "rpm") + +(test-equal "lead must be 96 bytes long" + 96 + (length (generate-lead "hello-2.12.1"))) + +(define header-entries + (list (make-header-entry RPMTAG_NAME 1 "hello") + (make-header-entry RPMTAG_VERSION 1 "2.12.1") + (make-header-entry RPMTAG_RELEASE 1 "0") + (make-header-entry RPMTAG_SUMMARY 1 + "Hello, GNU world: An example GNU package") + (make-header-entry RPMTAG_LICENSE 1 "GPL 3 or later") + (make-header-entry RPMTAG_OS 1 "Linux") + (make-header-entry RPMTAG_ARCH 1 "x86_64"))) + +(define expected-header-index-length + (* 16 (length header-entries))) ;16 bytes per index entry + +(define expected-header-data-length + (+ (length header-entries) ;to account for null bytes + (fold + 0 (map (compose string-length (cut header-entry-value <>)) + header-entries)))) + +(let ((index data (make-header-index+data header-entries))) + (test-equal "header index" + expected-header-index-length + (length index)) + + ;; This test depends on the fact that only STRING entries are used, and that + ;; they are composed of single byte characters and the delimiting null byte. + (test-equal "header data" + expected-header-data-length + (length data))) + +(test-equal "complete header section" + (+ 16 ;leading magic + count bytes + expected-header-index-length expected-header-data-length) + (length (make-header header-entries))) + +(test-end) -- cgit v1.2.3 From 84549dcf380b1ed7712816a1ff1bfe9688c1d9a7 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Wed, 4 Jan 2023 09:37:25 +0100 Subject: import: hackage: Add upstream-name property. * guix/import/hackage.scm (hackage-module->sexp): Add property upstream-name to imported package. * tests/hackage.scm (match-ghc-foo): Add upstream-name property. (match-ghc-foo-6): Ditto. (match-ghc-elif): Ditto. (match-ghc-foo-revision): Ditto. (match-ghc-foo-import): Ditto. --- guix/import/hackage.scm | 1 + tests/hackage.scm | 5 +++++ 2 files changed, 6 insertions(+) (limited to 'tests') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index e915aac58d..9e305cf080 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -314,6 +314,7 @@ the hash of the Cabal file." (bytevector->nix-base32-string (file-sha256 tarball)) "failed to download tar archive"))))) (build-system haskell-build-system) + (properties '((upstream-name . ,name))) ,@(maybe-inputs 'inputs dependencies) ,@(maybe-inputs 'native-inputs native-dependencies) ,@(maybe-arguments) diff --git a/tests/hackage.scm b/tests/hackage.scm index ad2ee4b7f9..8eea818ebd 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -201,6 +201,7 @@ library ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-http)) ('home-page "http://test.org") ('synopsis (? string?)) @@ -241,6 +242,7 @@ library ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-b 'ghc-http)) ('native-inputs ('list 'ghc-haskell-gi)) ('home-page "http://test.org") @@ -471,6 +473,7 @@ library ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-c)) ('home-page "http://test.org") ('synopsis (? string?)) @@ -520,6 +523,7 @@ executable cabal ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-http)) ('arguments ('quasiquote @@ -610,6 +614,7 @@ executable cabal ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-http)) ('home-page "http://test.org") ('synopsis (? string?)) -- cgit v1.2.3 From fee1d08f0dd183ef78bcb9f1534d7b9e7f1df7ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Feb 2023 15:35:54 +0100 Subject: pack: Make sure tests can run without a world rebuild. Commit 68380db4c40a2ee1156349a87254fd7b1f1a52d5 moved from 'gexp->derivation', which as a side effect, would lead tests to require a "world rebuild"--specifically, they'd have to build (default-guile). This was mitigated by 68775338a510f84e63657ab09242d79e726fa457, but that change introduced another regression. * guix/scripts/pack.scm (populate-profile-root): Define 'bootstrap?'. Pass #:guile to 'computed-file', with a value depending on 'bootstrap?'. * tests/pack.scm ("self-contained-tarball + localstatedir") ("docker-image + localstatedir", "squashfs-image + localstatedir") ("deb archive with symlinks and control files") ("rpm archive can be installed/uninstalled"): Use a record instead of a derivation. --- guix/scripts/pack.scm | 8 +++++++- tests/pack.scm | 40 ++++++++++++++++++++-------------------- 2 files changed, 27 insertions(+), 21 deletions(-) (limited to 'tests') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 51a7b8f185..eb41eb5563 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017-2022 Ludovic Courtès +;;; Copyright © 2015, 2017-2023 Ludovic Courtès ;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich @@ -220,6 +220,11 @@ items, which relies on hard links." (file-append (store-database (list profile)) "/db/db.sqlite"))) + (define bootstrap? + ;; Whether a '--bootstrap' environment is needed, for testing purposes. + ;; XXX: Infer that from available info. + (and (not database) (not (profile-locales? profile)))) + (define (import-module? module) ;; Since we don't use deduplication support in 'populate-store', don't ;; import (guix store deduplication) and its dependencies, which includes @@ -287,6 +292,7 @@ items, which relies on hard links." (for-each (cut evaluate-populate-directive <> #$output) directives))) #:local-build? #f + #:guile (if bootstrap? %bootstrap-guile (default-guile)) #:options (list #:references-graphs `(("profile" ,profile)) #:target target))) diff --git a/tests/pack.scm b/tests/pack.scm index 734ae1c69b..87187bb62c 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -138,10 +138,10 @@ (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)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (tarball (self-contained-tarball "tar-pack" profile #:localstatedir? #t)) (check (gexp->derivation "check-tarball" @@ -210,10 +210,10 @@ (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)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (tarball (docker-image "docker-pack" profile #:symlinks '(("/bin/Guile" -> "bin/guile")) #:localstatedir? #t)) @@ -250,10 +250,10 @@ (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)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (image (squashfs-image "squashfs-pack" profile #:symlinks '(("/bin" -> "bin")) #:localstatedir? #t)) @@ -288,10 +288,10 @@ (test-assertm "deb archive with symlinks and control files" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (deb (debian-archive "deb-pack" profile #:compressor %gzip-compressor @@ -376,10 +376,10 @@ (test-assertm "rpm archive can be installed/uninstalled" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (rpm-pack (rpm-archive "rpm-pack" profile #:compressor %gzip-compressor #:symlinks '(("/bin/guile" -> "bin/guile")) -- cgit v1.2.3 From 92a0e60a963a54230e400c5c2ae585205489bf35 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Feb 2023 23:20:26 +0100 Subject: pack: Adjust shell tests to read-only tarball root. Fixes . Fixes a regression introduced in 68380db4c40a2ee1156349a87254fd7b1f1a52d5, whereby the tarball's root entry is now read-only, due to the creation of "profile-directory" in the store. * tests/guix-pack.sh: Remove and recreate $test_directory before transformation option test. * tests/guix-pack-relocatable.sh: Add "chmod +w $test_directory" lines before attempts to write to it. --- tests/guix-pack-relocatable.sh | 6 +++++- tests/guix-pack.sh | 5 +++-- 2 files changed, 8 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index b90bc7f891..46120c9ee6 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2018, 2019, 2020 Ludovic Courtès +# Copyright © 2018, 2019, 2020, 2023 Ludovic Courtès # Copyright © 2020 Eric Bavier # # This file is part of GNU Guix. @@ -82,6 +82,7 @@ then tarball="`guix pack -R -S /Bin=bin sed`" (cd "$test_directory"; tar xvf "$tarball") + chmod +w "$test_directory" run_without_store "$test_directory/Bin/sed" --version > "$test_directory/output" grep 'GNU sed' "$test_directory/output" @@ -104,6 +105,7 @@ case "`uname -m`" in tarball="`guix pack -RR -S /Bin=bin sed`" tar tvf "$tarball" | grep /bin/proot (cd "$test_directory"; tar xf "$tarball") + chmod +w "$test_directory" run_without_store GUIX_EXECUTION_ENGINE="proot" \ "$test_directory/Bin/sed" --version > "$test_directory/output" grep 'GNU sed' "$test_directory/output" @@ -195,6 +197,7 @@ EOF # Run '/bin/daemon', which forks, then wait for the child, send it SIGHUP # so that it dumps its view of the store, and make sure the child and # parent both see the same store contents. + chmod +w "$test_directory" (cd "$test_directory"; run_without_store ./bin/daemon) wait_for_file "$test_directory/pid" kill -HUP $(cat "$test_directory/pid") @@ -241,6 +244,7 @@ cat >"$test_directory/manifest.scm" <<'EOF' EOF tarball="`guix pack -RR -S /opt= -m $test_directory/manifest.scm`" (cd "$test_directory"; tar xvf "$tarball") +chmod +w "$test_directory" ( export GUIX_PROFILE=$test_directory/opt . $GUIX_PROFILE/etc/profile run_without_store "$test_directory/opt/bin/hello" > "$test_directory/output" ) diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 6fc9e3723b..a13e0ededf 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -1,6 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2018 Chris Marusich -# Copyright © 2018, 2019, 2020, 2022 Ludovic Courtès +# Copyright © 2018, 2019, 2020, 2022, 2023 Ludovic Courtès # # This file is part of GNU Guix. # @@ -114,7 +114,8 @@ guix pack --dry-run --bootstrap --target=arm-linux-gnueabihf coreutils guix pack -R --dry-run --bootstrap -S /mybin=bin guile-bootstrap # Make sure package transformation options are honored. -mkdir -p "$test_directory" +chmod -Rf +w "$test_directory"; rm -r "$test_directory" +mkdir -p "$test_directory" -m 755 drv1="`guix pack --no-grafts -n guile 2>&1 | grep pack.*\.drv`" drv2="`guix pack --no-grafts -n --with-source=guile=$test_directory guile 2>&1 | grep pack.*\.drv`" test -n "$drv1" -- cgit v1.2.3 From 0a37921d851b94aef6900214098dc5bd62b46e26 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Mar 2023 11:31:12 +0100 Subject: read-print: Correctly handle comments that follow a list head. Fixes . Reported by Maxim Cournoyer . * guix/read-print.scm (pretty-print-with-comments)[starts-with-line-comment?]: New procedure. Use it when printing a list. * tests/read-print.scm: Add two tests. --- guix/read-print.scm | 9 ++++++++- tests/read-print.scm | 9 +++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/guix/read-print.scm b/guix/read-print.scm index 46b722eeed..fdc85c2693 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -529,6 +529,12 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (pair? tail))) (_ #f))) + (define (starts-with-line-comment? lst) + ;; Return true if LST starts with a line comment. + (match lst + ((x . _) (and (comment? x) (not (comment-margin? x)))) + (_ #f))) + (let loop ((indent indent) (column indent) (delimited? #t) ;true if comes after a delimiter @@ -710,7 +716,8 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (+ indent 1) (+ column (if delimited? 1 2)))) (newline? (or (newline-form? head context) - (list-of-lists? head tail))) ;'let' bindings + (list-of-lists? head tail) ;'let' bindings + (starts-with-line-comment? tail))) (context (cons head context))) (if overflow? (begin diff --git a/tests/read-print.scm b/tests/read-print.scm index 79a4101be6..952b3e6585 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -210,6 +210,15 @@ mnopqrstuvwxyz.\")" \"abcdefghijklmnopqrstuvwxyz\")" #:max-width 33) +(test-pretty-print "\ +(list ;margin comment + a b c)") + +(test-pretty-print "\ +(list + ;; This is a line comment immediately following the list head. + #:test-flags #~(list \"-m\" \"not external and not samples\"))") + (test-pretty-print "\ (modify-phases %standard-phases (replace 'build -- cgit v1.2.3 From 9fb8a480d5aec9186908e92ad18b31455f4aab6b Mon Sep 17 00:00:00 2001 From: Simon Tournier Date: Sat, 11 Mar 2023 17:51:10 +0100 Subject: packages: Consider 'patches' by 'package-direct-sources'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/packages.scm (package-direct-sources): Return 'origin' from 'patches'. * tests/packages.scm: Test it. Signed-off-by: Ludovic Courtès --- guix/packages.scm | 10 ++++++++-- tests/packages.scm | 17 ++++++++++++++++- 2 files changed, 24 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/guix/packages.scm b/guix/packages.scm index 041a872f9d..7b098e21f0 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2021 Chris Marusich ;;; Copyright © 2022 Maxime Devos ;;; Copyright © 2022 jgart +;;; Copyright © 2023 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -1239,8 +1240,13 @@ input list." (define (package-direct-sources package) "Return all source origins associated with PACKAGE; including origins in -PACKAGE's inputs." - `(,@(or (and=> (package-source package) list) '()) +PACKAGE's inputs and patches." + (define (expand source) + (cons + source + (filter origin? (origin-patches source)))) + + `(,@(or (and=> (package-source package) expand) '()) ,@(filter-map (match-lambda ((_ (? origin? orig) _ ...) orig) diff --git a/tests/packages.scm b/tests/packages.scm index f58c47817b..27fb918f90 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Maxime Devos +;;; Copyright © 2023 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -418,12 +419,15 @@ (let* ((o (dummy-origin)) (u (dummy-origin)) (i (dummy-origin)) + (j (dummy-origin (patches (list o)))) (a (dummy-package "a")) (b (dummy-package "b" (inputs (list a i)))) (c (package (inherit b) (source o))) (d (dummy-package "d" (build-system trivial-build-system) - (source u) (inputs (list c))))) + (source u) (inputs (list c)))) + (e (dummy-package "e" (source j))) + (f (package (inherit e) (inputs (list u))))) (test-assert "package-direct-sources, no source" (null? (package-direct-sources a))) (test-equal "package-direct-sources, #f source" @@ -437,6 +441,17 @@ (and (= (length (pk 's-sources s)) 2) (member o s) (member i s)))) + (test-assert "package-direct-sources, with patches" + (let ((s (package-direct-sources e))) + (and (= (length (pk 's-sources s)) 2) + (member o s) + (member j s)))) + (test-assert "package-direct-sources, with patches and inputs" + (let ((s (package-direct-sources f))) + (and (= (length (pk 's-sources s)) 3) + (member o s) + (member j s) + (member u s)))) (test-assert "package-transitive-sources" (let ((s (package-transitive-sources d))) (and (= (length (pk 'd-sources s)) 3) -- cgit v1.2.3 From eee95b5a879b7096dffd533f24107cf8926b621e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Mar 2023 12:53:20 +0100 Subject: packages: 'package-input-rewriting/spec' ignores hidden packages. The primary motivation is to support things like: guix build guix --with-input=guile=guile-next without triggering a rebuild of (@@ (gnu packages commencement) guile-final) and similar things. It is also consistent with package name resolution on the command line: a package that cannot be named cannot be replaced. * guix/packages.scm (package-input-rewriting/spec)[rewrite]: When P is hidden, return it as-is. * tests/packages.scm ("package-input-rewriting/spec, hidden package"): New test. * doc/guix.texi (Defining Package Variants): Update. (Package Transformation Options): Update '--with-input' example. --- doc/guix.texi | 21 ++++++++++++--------- guix/packages.scm | 7 +++++-- tests/packages.scm | 20 +++++++++++++++++++- 3 files changed, 36 insertions(+), 12 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 3814e60467..95c954bfcf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8331,10 +8331,13 @@ be replaced by name rather than by identity. @deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t] Return a procedure that, given a package, applies the given @var{replacements} to all the package graph, including implicit inputs -unless @var{deep?} is false. @var{replacements} is a list of -spec/procedures pair; each spec is a package specification such as -@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching -package and returns a replacement for that package. +unless @var{deep?} is false. + +@var{replacements} is a list of spec/procedures pair; each spec is a +package specification such as @code{"gcc"} or @code{"guile@@2"}, and +each procedure takes a matching package and returns a replacement for +that package. Matching packages that have the @code{hidden?} property +set are not replaced. @end deffn The example above could be rewritten this way: @@ -12664,18 +12667,18 @@ or @code{guile@@1.8}. For instance, the following command builds Guix, but replaces its dependency on the current stable version of Guile with a dependency on -the legacy version of Guile, @code{guile@@2.0}: +the legacy version of Guile, @code{guile@@2.2}: @example -guix build --with-input=guile=guile@@2.0 guix +guix build --with-input=guile=guile@@2.2 guix @end example This is a recursive, deep replacement. So in this example, both @code{guix} and its dependency @code{guile-json} (which also depends on -@code{guile}) get rebuilt against @code{guile@@2.0}. +@code{guile}) get rebuilt against @code{guile@@2.2}. -This is implemented using the @code{package-input-rewriting} Scheme -procedure (@pxref{Defining Packages, @code{package-input-rewriting}}). +This is implemented using the @code{package-input-rewriting/spec} Scheme +procedure (@pxref{Defining Packages, @code{package-input-rewriting/spec}}). @item --with-graft=@var{package}=@var{replacement} This is similar to @option{--with-input} but with an important difference: diff --git a/guix/packages.scm b/guix/packages.scm index ca958c6eae..4c0c194652 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1533,9 +1533,11 @@ package and returns its new name after rewrite." (define* (package-input-rewriting/spec replacements #:key (deep? #t)) "Return a procedure that, given a package, applies the given REPLACEMENTS to all the package graph, including implicit inputs unless DEEP? is false. + REPLACEMENTS is a list of spec/procedures pair; each spec is a package specification such as \"gcc\" or \"guile@2\", and each procedure takes a -matching package and returns a replacement for that package." +matching package and returns a replacement for that package. Matching +packages that have the 'hidden?' property set are not replaced." (define table (fold (lambda (replacement table) (match replacement @@ -1563,7 +1565,8 @@ matching package and returns a replacement for that package." (gensym " package-replacement")) (define (rewrite p) - (if (assq-ref (package-properties p) replacement-property) + (if (or (assq-ref (package-properties p) replacement-property) + (hidden-package? p)) p (match (find-replacement p) (#f p) diff --git a/tests/packages.scm b/tests/packages.scm index 27fb918f90..ef97fca86d 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès +;;; Copyright © 2012-2023 Ludovic Courtès ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Maxime Devos @@ -1592,6 +1592,24 @@ (match (delete-duplicates pythons eq?) ((p) (eq? p (rewrite python)))))) +(test-assert "package-input-rewriting/spec, hidden package" + ;; Hidden packages are not subject to rewriting. + (let* ((python (hidden-package python)) + (p0 (dummy-package "chbouib" + (build-system trivial-build-system) + (inputs (list python)))) + (rewrite (package-input-rewriting/spec + `(("python" . ,(const sed))) + #:deep? #t)) + (p1 (rewrite p0)) + (bag1 (package->bag p1)) + (pythons (filter-map (match-lambda + (("python" python) python) + (_ #f)) + (bag-transitive-inputs bag1)))) + (match (delete-duplicates pythons eq?) + ((p) (eq? p python))))) + (test-equal "package-input-rewriting/spec, graft" (derivation-file-name (package-derivation %store sed)) -- cgit v1.2.3 From 83128f00e9149f3c1bcd4450eb0ed3620a37149c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Mar 2023 22:18:52 +0100 Subject: read-print: 'read-with-comments' reads comments within gexps. Fixes . Reported by Maxim Cournoyer . * guix/read-print.scm (read-with-comments): Special-case #~, #$, and #+. * tests/read-print.scm: Add two tests. --- guix/read-print.scm | 21 +++++++++++++++++++++ tests/read-print.scm | 15 +++++++++++++++ 2 files changed, 36 insertions(+) (limited to 'tests') diff --git a/guix/read-print.scm b/guix/read-print.scm index fdc85c2693..515eb7669c 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -219,6 +219,27 @@ BLANK-LINE? is true, assume PORT is at the beginning of a new line." (list 'quote (loop #f return))) ((eq? chr #\`) (list 'quasiquote (loop #f return))) + ((eq? chr #\#) + (match (read-char port) + (#\~ (list 'gexp (loop #f return))) + (#\$ (list (match (peek-char port) + (#\@ + (read-char port) ;consume + 'ungexp-splicing) + (_ + 'ungexp)) + (loop #f return))) + (#\+ (list (match (peek-char port) + (#\@ + (read-char port) ;consume + 'ungexp-native-splicing) + (_ + 'ungexp-native)) + (loop #f return))) + (chr + (unread-char chr port) + (unread-char #\# port) + (read port)))) ((eq? chr #\,) (list (match (peek-char port) (#\@ diff --git a/tests/read-print.scm b/tests/read-print.scm index 952b3e6585..f4627e076a 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -231,6 +231,21 @@ mnopqrstuvwxyz.\")" ;; Regular indentation for 'replace' here. (replace \"gmp\" gmp))") +(test-pretty-print "\ +#~(modify-phases phases + (add-after 'whatever 'something-else + (lambda _ + ;; This comment appears inside a gexp. + 42)))") + +(test-pretty-print "\ +#~(list #$@(list coreutils ;yup + grep) ;margin comment + #+sed + + ;; Line comment. + #$grep)") + (test-pretty-print "\ (package ;; Here 'sha256', 'base32', and 'arguments' must be -- cgit v1.2.3 From 933051281fbed0ae71bd40c24a701faf2a02791c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 17 Mar 2023 12:14:14 -0400 Subject: Revert "tests: pack: Fix indentation." This reverts commit ac1d530d56c1a259630c8873b2281033878a4acb. --- tests/pack.scm | 279 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 142 insertions(+), 137 deletions(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index 87187bb62c..ce5a2f8a53 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -88,43 +88,44 @@ -> "bin/guile")) #:compressor %gzip-compressor #:archiver %tar-bootstrap)) - (check (gexp->derivation "check-tarball" - (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"))))))))) + (check (gexp->derivation + "check-tarball" + (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 @@ -144,16 +145,17 @@ (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)))))))) + (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)) @@ -166,44 +168,45 @@ ("λ" regular (data "lambda"))))) (tarball (self-contained-tarball "tar-pack" tree #:localstatedir? #t)) - (check (gexp->derivation "check-tarball" - (with-extensions (list guile-sqlite3 guile-gcrypt) - (with-imported-modules (source-module-closure - '((guix store database))) - #~(begin - (use-modules (guix store database) - (rnrs io ports) - (srfi srfi-1)) - - (define (valid-file? basename data) - (define file - (string-append "./" #$tree "/" basename)) - - (string=? (call-with-input-file (pk 'file file) - get-string-all) - data)) - - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - - (sql-schema - #$(local-file (search-path %load-path - "guix/store/schema.sql"))) - (with-database "var/guix/db/db.sqlite" db - ;; Make sure non-ASCII file names are properly - ;; handled. - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales - "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - (mkdir #$output) - (exit - (and (every valid-file? - '("α" "λ") - '("alpha" "lambda")) - (integer? (path-id db #$tree))))))))))) + (check (gexp->derivation + "check-tarball" + (with-extensions (list guile-sqlite3 guile-gcrypt) + (with-imported-modules (source-module-closure + '((guix store database))) + #~(begin + (use-modules (guix store database) + (rnrs io ports) + (srfi srfi-1)) + + (define (valid-file? basename data) + (define file + (string-append "./" #$tree "/" basename)) + + (string=? (call-with-input-file (pk 'file file) + get-string-all) + data)) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + + (sql-schema + #$(local-file (search-path %load-path + "guix/store/schema.sql"))) + (with-database "var/guix/db/db.sqlite" db + ;; Make sure non-ASCII file names are properly + ;; handled. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales + "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (mkdir #$output) + (exit + (and (every valid-file? + '("α" "λ") + '("alpha" "lambda")) + (integer? (path-id db #$tree))))))))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -217,33 +220,34 @@ (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") - (file-is-directory? "tmp") - (string=? (string-append #$%bootstrap-guile "/bin") - (pk 'binlink (readlink bin))) - (string=? (string-append #$profile "/bin/guile") - (pk 'guilelink (readlink "bin/Guile")))) - (mkdir #$output))))))) + (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") + (file-is-directory? "tmp") + (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)))) (unless store (test-skip 1)) @@ -257,31 +261,32 @@ (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 "/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))) - - ;; This is a relative symlink target. - (string=? (string-drop - (string-append #$profile "/bin") - 1) - (pk 'guilelink (readlink "bin")))) - (mkdir #$output)))))))) + (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 "/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))) + + ;; This is a relative symlink target. + (string=? (string-drop + (string-append #$profile "/bin") + 1) + (pk 'guilelink (readlink "bin")))) + (mkdir #$output)))))))) (built-derivations (list check)))) (unless store (test-skip 1)) -- cgit v1.2.3