From b0057b0a3b3de5bf2b710fe5aeab5466ade8fb8c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 21 Jan 2023 15:04:09 -0500 Subject: pack: Add RPM format. --- Makefile.am | 2 + guix/rpm.scm | 553 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pack.scm | 155 +++++++++++++- tests/pack.scm | 54 ++++- tests/rpm.scm | 86 ++++++++ 5 files changed, 847 insertions(+), 3 deletions(-) create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm diff --git a/Makefile.am b/Makefile.am index a4b6f03b3a..ac4485dd30 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 \ @@ -533,6 +534,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/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..231b302d2f --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,553 @@ +;;; 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 . + +;;; 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. + +(define-module (guix rpm) + #:use-module (gcrypt hash) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #: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)) + +(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_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))) + +(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)))) + ;; 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 files))) + ;; The files owned are those appearing in 'basenames'; own them + ;; all. + (basenames (map basename 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 + files)) + (file-modes (map stat:mode file-stats)) + (file-sizes (map stat:size file-stats)) + (file-md5s (files->md5-checksums 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? + (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)))) + (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 (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 7a5fb9bd0d..16eb10f6c7 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 @@ -865,6 +866,151 @@ 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. The supported +compressors are \"none\", \"gz\", \"xz\" or \"zstd\". 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? can be +provided via EXTRA-OPTIONS to denote a relocatable package." + + (define %supported-compressors '("none" "gzip" "xz" "zstd")) + + (let ((compressor-name (compressor-name compressor))) + (unless (member compressor-name %supported-compressors) + (leave (G_ "~a is not a supported RPM archive compressor. \ +Supported compressors are: ~a~%") compressor-name %supported-compressors))) + + (define relocatable? (keyword-ref extra-options #:relocatable?)) + + (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))) + #~(begin + (use-modules (guix build utils) + (guix cpio)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion #$root + ;; The first "." entry is discarded. + (write-cpio-archive (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 + (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))) + + (define header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? #$relocatable?)) + + (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. ;;; @@ -1196,7 +1342,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. @@ -1210,6 +1357,8 @@ 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 %deb-format-options @@ -1492,6 +1641,8 @@ Create a bundle of PACKAGE.\n")) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable?)) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/tests/pack.scm b/tests/pack.scm index 2e3b9d0ca4..f113f05b2f 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,9 +28,11 @@ #: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)) @@ -59,6 +61,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") @@ -360,6 +373,45 @@ (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)) + + ;; Setup RPM. + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install RPM package. + (mkdir "test-prefix") + (invoke rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; ;; Invoked installed Guile command. + ;; (invoke "./test-prefix/bin/guile" "--version") + + ;; ;; Uninstall RPM package. + ;; (invoke rpm "--erase" "guile") + + ;; 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..5b0ce43d86 --- /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, which + ;; use one byte per character + the delimiting null byte for each string. + (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