pack: Add RPM format.rpm-works

5 files changed, 847 insertions, 3 deletions

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 <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/>.
+
+;;; 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 <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_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)))
+
+(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
+<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?
+                          (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 <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
 
@@ -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 <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,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")
 
@@ -361,6 +374,45 @@
                   (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)))))
 
 (test-end)
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 <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, 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)