diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 46 | ||||
| -rw-r--r-- | guix/rpm.scm | 623 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 230 | ||||
| -rw-r--r-- | tests/pack.scm | 57 | ||||
| -rw-r--r-- | tests/rpm.scm | 86 |
6 files changed, 1031 insertions, 13 deletions
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 <maxim.cournoyer@gmail.com> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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 <rpm-tag> + (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 <rpm-tag> object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type <header-entry> + (make-header-entry tag count value) + header-entry? + (tag header-entry-tag) ;<rpm-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 <header-entry> 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 +<rpm-entry> 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 <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; @@ -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 <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; 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") @@ -356,6 +370,47 @@ (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))))) (test-end) 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 <maxim.cournoyer@gmail.com> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(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) |