diff options
Diffstat (limited to 'guix/scripts/pack.scm')
| -rw-r--r-- | guix/scripts/pack.scm | 155 |
1 files changed, 153 insertions, 2 deletions
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?)) |