me
/
guix
Archived
1
0
Fork 0

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.
Maxim Cournoyer 2023-01-21 15:04:09 -05:00
parent ac1d530d56
commit 598f4c509b
No known key found for this signature in database
GPG Key ID: 1260E46482E63562
6 changed files with 1031 additions and 13 deletions

View File

@ -111,6 +111,7 @@ MODULES = \
guix/derivations.scm \ guix/derivations.scm \
guix/grafts.scm \ guix/grafts.scm \
guix/repl.scm \ guix/repl.scm \
guix/rpm.scm \
guix/transformations.scm \ guix/transformations.scm \
guix/inferior.scm \ guix/inferior.scm \
guix/describe.scm \ guix/describe.scm \
@ -535,6 +536,7 @@ SCM_TESTS = \
tests/pypi.scm \ tests/pypi.scm \
tests/read-print.scm \ tests/read-print.scm \
tests/records.scm \ tests/records.scm \
tests/rpm.scm \
tests/scripts.scm \ tests/scripts.scm \
tests/search-paths.scm \ tests/search-paths.scm \
tests/services.scm \ tests/services.scm \

View File

@ -6896,6 +6896,7 @@ such file or directory'' message.
@end quotation @end quotation
@item deb @item deb
@cindex Debian, build a .deb package with guix pack
This produces a Debian archive (a package with the @samp{.deb} file This produces a Debian archive (a package with the @samp{.deb} file
extension) containing all the specified binaries and symbolic links, extension) containing all the specified binaries and symbolic links,
that can be installed on top of any dpkg-based GNU(/Linux) distribution. 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 Because archives produced with @command{guix pack} contain a collection
of store items and because each @command{dpkg} package must not have 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 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 @end quotation
@quotation Warning @quotation Warning
@ -6923,6 +6925,48 @@ shared by other software, such as a Guix installation or other, non-deb
packs. packs.
@end quotation @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 @end table
@cindex relocatable binaries @cindex relocatable binaries

623
guix/rpm.scm 100644
View File

@ -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))))

View File

@ -5,7 +5,7 @@
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> ;;; 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 © 2020 Eric Bavier <bavier@posteo.net>
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
;;; ;;;
@ -67,6 +67,7 @@
self-contained-tarball self-contained-tarball
debian-archive debian-archive
rpm-archive
docker-image docker-image
squashfs-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. ;;; Compiling C programs.
;;; ;;;
@ -1187,7 +1348,8 @@ last resort for relocation."
`((tarball . ,self-contained-tarball) `((tarball . ,self-contained-tarball)
(squashfs . ,squashfs-image) (squashfs . ,squashfs-image)
(docker . ,docker-image) (docker . ,docker-image)
(deb . ,debian-archive))) (deb . ,debian-archive)
(rpm . ,rpm-archive)))
(define (show-formats) (define (show-formats)
;; Print the supported pack formats. ;; Print the supported pack formats.
@ -1201,18 +1363,22 @@ last resort for relocation."
docker Tarball ready for 'docker load'")) docker Tarball ready for 'docker load'"))
(display (G_ " (display (G_ "
deb Debian archive installable via dpkg/apt")) deb Debian archive installable via dpkg/apt"))
(display (G_ "
rpm RPM archive installable via rpm/yum"))
(newline)) (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 (define %deb-format-options
(let ((required-option (lambda (symbol) (list (required-option 'control-file)
(option (list (symbol->string symbol)) #t #f (required-option 'postinst-file)
(lambda (opt name arg result . rest) (required-option 'triggers-file)))
(apply values
(alist-cons symbol arg result)
rest))))))
(list (required-option 'control-file)
(required-option 'postinst-file)
(required-option 'triggers-file))))
(define (show-deb-format-options) (define (show-deb-format-options)
(display (G_ " (display (G_ "
@ -1231,6 +1397,32 @@ last resort for relocation."
(newline) (newline)
(exit 0)) (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 (define %options
;; Specifications of the command-line options. ;; Specifications of the command-line options.
(cons* (option '(#\h "help") #f #f (cons* (option '(#\h "help") #f #f
@ -1307,7 +1499,12 @@ last resort for relocation."
(lambda args (lambda args
(show-deb-format-options/detailed))) (show-deb-format-options/detailed)))
(option '("help-rpm-format") #f #f
(lambda args
(show-rpm-format-options/detailed)))
(append %deb-format-options (append %deb-format-options
%rpm-format-options
%transformation-options %transformation-options
%standard-build-options %standard-build-options
%standard-cross-build-options %standard-cross-build-options
@ -1325,6 +1522,7 @@ Create a bundle of PACKAGE.\n"))
(show-transformation-options-help) (show-transformation-options-help)
(newline) (newline)
(show-deb-format-options) (show-deb-format-options)
(show-rpm-format-options)
(newline) (newline)
(display (G_ " (display (G_ "
-f, --format=FORMAT build a pack in the given FORMAT")) -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) (process-file-arg opts 'postinst-file)
#:triggers-file #:triggers-file
(process-file-arg opts '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)) (target (assoc-ref opts 'target))
(bootstrap? (assoc-ref opts 'bootstrap?)) (bootstrap? (assoc-ref opts 'bootstrap?))

View File

@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -28,13 +28,16 @@
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix utils)
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module ((gnu packages base) #:select (glibc-utf8-locales))
#:use-module (gnu packages bootstrap) #: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 compression) #:select (squashfs-tools))
#:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages debian) #:select (dpkg))
#:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages guile) #:select (guile-sqlite3))
#:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
#:use-module ((gnu packages linux) #:select (fakeroot))
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64))
(define %store (define %store
@ -59,6 +62,17 @@
(define %ar-bootstrap %bootstrap-binutils) (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") (test-begin "pack")
@ -355,6 +369,47 @@
(stat "postinst")))))) (stat "postinst"))))))
(assert (file-exists? "triggers")) (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)))))) (mkdir #$output))))))
(built-derivations (list check))))) (built-derivations (list check)))))

86
tests/rpm.scm 100644
View File

@ -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)