summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorMaxim Cournoyer <maxim.cournoyer@gmail.com>2023-01-21 15:04:09 -0500
committerMaxim Cournoyer <maxim.cournoyer@gmail.com>2023-02-19 21:13:23 -0500
commit598f4c509bbfec2b983a8ee246cce0a0fe45ec7f (patch)
tree1bf799843929f714428c27eb2325c255a92793f3 /guix/scripts
parentac1d530d56c1a259630c8873b2281033878a4acb (diff)
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.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/pack.scm230
1 files changed, 219 insertions, 11 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 77425e5b0f..701e41ff1a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -5,7 +5,7 @@
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
;;;
@@ -67,6 +67,7 @@
self-contained-tarball
debian-archive
+ rpm-archive
docker-image
squashfs-image
@@ -856,6 +857,166 @@ Section: misc
;;;
+;;; RPM archive format.
+;;;
+(define* (rpm-archive name profile
+ #:key target
+ (profile-name "guix-profile")
+ entry-point
+ (compressor (first %compressors))
+ deduplicate?
+ localstatedir?
+ (symlinks '())
+ archiver
+ (extra-options '()))
+ "Return a RPM archive (.rpm) containing a store initialized with the closure
+of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be
+a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack.
+ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE,
+PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS."
+ (when entry-point
+ (warning (G_ "entry point not supported in the '~a' format~%") 'rpm))
+
+ (define root (populate-profile-root profile
+ #:profile-name profile-name
+ #:target target
+ #:localstatedir? localstatedir?
+ #:deduplicate? deduplicate?
+ #:symlinks symlinks))
+
+ (define payload
+ (let* ((raw-cpio-file-name "payload.cpio")
+ (compressed-cpio-file-name (string-append raw-cpio-file-name
+ (compressor-extension
+ compressor))))
+ (computed-file compressed-cpio-file-name
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (guix cpio)
+ (guix rpm)))
+ #~(begin
+ (use-modules (guix build utils)
+ (guix cpio)
+ (guix rpm)
+ (srfi srfi-1))
+
+ ;; Make sure non-ASCII file names are properly handled.
+ #+(set-utf8-locale profile)
+
+ (define %root (if #$localstatedir? "." #$root))
+
+ (when #$localstatedir?
+ ;; Fix the permission of the Guix database file, which was made
+ ;; read-only when copied to the store in populate-profile-root.
+ (copy-recursively #$root %root)
+ (chmod (string-append %root "/var/guix/db/db.sqlite") #o644))
+
+ (call-with-output-file #$raw-cpio-file-name
+ (lambda (port)
+ (with-directory-excursion %root
+ ;; The first "." entry is discarded.
+ (write-cpio-archive
+ (remove fhs-directory?
+ (cdr (find-files "." #:directories? #t)))
+ port))))
+ (when #+(compressor-command compressor)
+ (apply invoke (append #+(compressor-command compressor)
+ (list #$raw-cpio-file-name))))
+ (copy-file #$compressed-cpio-file-name #$output)))
+ #:local-build? #f))) ;allow offloading
+
+ (define build
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ `((gcrypt hash)
+ (guix build utils)
+ (guix profiles)
+ (guix rpm))
+ #:select? not-config?))
+ #~(begin
+ (use-modules (gcrypt hash)
+ (guix build utils)
+ (guix profiles)
+ (guix rpm)
+ (ice-9 binary-ports)
+ (ice-9 match) ;for manifest->friendly-name
+ (ice-9 optargs)
+ (rnrs bytevectors)
+ (srfi srfi-1))
+
+ (define machine-type
+ (and=> (or #$target %host-type)
+ (lambda (triplet)
+ (first (string-split triplet #\-)))))
+
+ #$(procedure-source manifest->friendly-name)
+
+ (define manifest (profile-manifest #$profile))
+
+ (define single-entry ;manifest entry
+ (match (manifest-entries manifest)
+ ((entry)
+ entry)
+ (_ #f)))
+
+ (define name
+ (or (and=> single-entry manifest-entry-name)
+ (manifest->friendly-name manifest)))
+
+ (define version
+ (or (and=> single-entry manifest-entry-version) "0.0.0"))
+
+ (define lead
+ (generate-lead (string-append name "-" version)
+ #:target (or #$target %host-type)))
+
+ (define payload-digest
+ (bytevector->hex-string (file-sha256 #$payload)))
+
+ (let-keywords '#$extra-options #f ((relocatable? #f)
+ (prein-file #f)
+ (postin-file #f)
+ (preun-file #f)
+ (postun-file #f))
+
+ (let ((header (generate-header name version
+ payload-digest
+ #$root
+ #$(compressor-name compressor)
+ #:target (or #$target %host-type)
+ #:relocatable? relocatable?
+ #:prein-file prein-file
+ #:postin-file postin-file
+ #:preun-file preun-file
+ #:postun-file postun-file)))
+
+ (define header-sha256
+ (bytevector->hex-string (sha256 (u8-list->bytevector header))))
+
+ (define payload-size (stat:size (stat #$payload)))
+
+ (define header+compressed-payload-size
+ (+ (length header) payload-size))
+
+ (define signature
+ (generate-signature header-sha256
+ header+compressed-payload-size))
+
+ ;; Serialize the archive components to a file.
+ (call-with-input-file #$payload
+ (lambda (in)
+ (call-with-output-file #$output
+ (lambda (out)
+ (put-bytevector out (assemble-rpm-metadata lead
+ signature
+ header))
+ (sendfile out in payload-size)))))))))))
+
+ (gexp->derivation (string-append name ".rpm") build))
+
+
+;;;
;;; Compiling C programs.
;;;
@@ -1187,7 +1348,8 @@ last resort for relocation."
`((tarball . ,self-contained-tarball)
(squashfs . ,squashfs-image)
(docker . ,docker-image)
- (deb . ,debian-archive)))
+ (deb . ,debian-archive)
+ (rpm . ,rpm-archive)))
(define (show-formats)
;; Print the supported pack formats.
@@ -1201,18 +1363,22 @@ last resort for relocation."
docker Tarball ready for 'docker load'"))
(display (G_ "
deb Debian archive installable via dpkg/apt"))
+ (display (G_ "
+ rpm RPM archive installable via rpm/yum"))
(newline))
+(define (required-option symbol)
+ "Return an SYMBOL option that requires a value."
+ (option (list (symbol->string symbol)) #t #f
+ (lambda (opt name arg result . rest)
+ (apply values
+ (alist-cons symbol arg result)
+ rest))))
+
(define %deb-format-options
- (let ((required-option (lambda (symbol)
- (option (list (symbol->string symbol)) #t #f
- (lambda (opt name arg result . rest)
- (apply values
- (alist-cons symbol arg result)
- rest))))))
- (list (required-option 'control-file)
- (required-option 'postinst-file)
- (required-option 'triggers-file))))
+ (list (required-option 'control-file)
+ (required-option 'postinst-file)
+ (required-option 'triggers-file)))
(define (show-deb-format-options)
(display (G_ "
@@ -1231,6 +1397,32 @@ last resort for relocation."
(newline)
(exit 0))
+(define %rpm-format-options
+ (list (required-option 'prein-file)
+ (required-option 'postin-file)
+ (required-option 'preun-file)
+ (required-option 'postun-file)))
+
+(define (show-rpm-format-options)
+ (display (G_ "
+ --help-rpm-format list options specific to the RPM format")))
+
+(define (show-rpm-format-options/detailed)
+ (display (G_ "
+ --prein-file=FILE
+ Embed the provided prein script"))
+ (display (G_ "
+ --postin-file=FILE
+ Embed the provided postin script"))
+ (display (G_ "
+ --preun-file=FILE
+ Embed the provided preun script"))
+ (display (G_ "
+ --postun-file=FILE
+ Embed the provided postun script"))
+ (newline)
+ (exit 0))
+
(define %options
;; Specifications of the command-line options.
(cons* (option '(#\h "help") #f #f
@@ -1307,7 +1499,12 @@ last resort for relocation."
(lambda args
(show-deb-format-options/detailed)))
+ (option '("help-rpm-format") #f #f
+ (lambda args
+ (show-rpm-format-options/detailed)))
+
(append %deb-format-options
+ %rpm-format-options
%transformation-options
%standard-build-options
%standard-cross-build-options
@@ -1325,6 +1522,7 @@ Create a bundle of PACKAGE.\n"))
(show-transformation-options-help)
(newline)
(show-deb-format-options)
+ (show-rpm-format-options)
(newline)
(display (G_ "
-f, --format=FORMAT build a pack in the given FORMAT"))
@@ -1483,6 +1681,16 @@ Create a bundle of PACKAGE.\n"))
(process-file-arg opts 'postinst-file)
#:triggers-file
(process-file-arg opts 'triggers-file)))
+ ('rpm
+ (list #:relocatable? relocatable?
+ #:prein-file
+ (process-file-arg opts 'prein-file)
+ #:postin-file
+ (process-file-arg opts 'postin-file)
+ #:preun-file
+ (process-file-arg opts 'preun-file)
+ #:postun-file
+ (process-file-arg opts 'postun-file)))
(_ '())))
(target (assoc-ref opts 'target))
(bootstrap? (assoc-ref opts 'bootstrap?))