aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el1
-rw-r--r--NEWS7
-rw-r--r--doc/guix.texi5
-rw-r--r--guix/scripts/pack.scm180
-rw-r--r--tests/pack.scm75
5 files changed, 265 insertions, 3 deletions
diff --git a/.dir-locals.el b/.dir-locals.el
index 8f07a08eb5..a4fcbfe7ca 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -75,6 +75,7 @@
(eval . (put 'origin 'scheme-indent-function 0))
(eval . (put 'build-system 'scheme-indent-function 0))
(eval . (put 'bag 'scheme-indent-function 0))
+ (eval . (put 'gexp->derivation 'scheme-indent-function 1))
(eval . (put 'graft 'scheme-indent-function 0))
(eval . (put 'operating-system 'scheme-indent-function 0))
(eval . (put 'file-system 'scheme-indent-function 0))
diff --git a/NEWS b/NEWS
index 1d3f5aaffd..b0647b3700 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,7 @@
Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
+Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
@@ -11,10 +12,12 @@ Copyright © 2016, 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
Please send Guix bug reports to bug-guix@gnu.org.
-* Changes in 1.3.0 (since 1.2.0)
-
+* Changes in 1.4.0 (since 1.3.0)
** Package management
+ * New 'deb' format for the 'guix pack' command
+* Changes in 1.3.0 (since 1.2.0)
+** Package management
*** POWER9 (powerpc64le-linux) is now supported as a technology preview
*** New ‘--export-manifest’ and ‘--export-channels’ options of ‘guix package’
*** New ‘--profile’ option for ‘guix environment’
diff --git a/doc/guix.texi b/doc/guix.texi
index 37936bb0f3..e0668b1f5f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6028,6 +6028,11 @@ This produces a SquashFS image containing all the specified binaries and
symlinks, as well as empty mount points for virtual file systems like
procfs.
+@item deb
+This produces a Debian archive (a package with the @samp{.deb} file
+extension) containing all the specified binaries and symbolic links,
+that can be installed on top of any dpkg-based GNU/Linux distribution.
+
@quotation Note
Singularity @emph{requires} you to provide @file{/bin/sh} in the image.
For that reason, @command{guix pack -f squashfs} always implies @code{-S
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index cee1444110..6d8b70d1c7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -6,6 +6,7 @@
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -65,6 +66,7 @@
%compressors
lookup-compressor
self-contained-tarball
+ debian-archive
docker-image
squashfs-image
@@ -346,6 +348,10 @@ added to the pack."
#:target target
#:references-graphs `(("profile" ,profile))))
+
+;;;
+;;; Singularity.
+;;;
(define (singularity-environment-file profile)
"Return a shell script that defines the environment variables corresponding
to the search paths of PROFILE."
@@ -372,6 +378,10 @@ to the search paths of PROFILE."
(computed-file "singularity-environment.sh" build))
+
+;;;
+;;; SquashFS image format.
+;;;
(define* (squashfs-image name profile
#:key target
(profile-name "guix-profile")
@@ -546,6 +556,10 @@ added to the pack."
#:target target
#:references-graphs `(("profile" ,profile))))
+
+;;;
+;;; Docker image format.
+;;;
(define* (docker-image name profile
#:key target
(profile-name "guix-profile")
@@ -635,6 +649,167 @@ the image."
;;;
+;;; Debian archive format.
+;;;
+;;; TODO: When relocatable option is selected, install to a unique prefix.
+;;; This would enable installation of multiple deb packs with conflicting
+;;; files at the same time.
+;;; TODO: Allow passing a custom control file from the CLI.
+;;; TODO: Allow providing a postinst script.
+(define* (debian-archive name profile
+ #:key target
+ (profile-name "guix-profile")
+ deduplicate?
+ entry-point
+ (compressor (first %compressors))
+ localstatedir?
+ (symlinks '())
+ (archiver tar))
+ "Return a Debian archive (.deb) containing a store initialized with the
+closure of PROFILE, a derivation. The archive contains /gnu/store; if
+LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db
+with a properly initialized store database. The supported compressors are
+\"none\", \"gz\" or \"xz\".
+
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
+added to the pack."
+ ;; For simplicity, limit the supported compressors to the superset of
+ ;; compressors able to compress both the control file (gz or xz) and the
+ ;; data tarball (gz, bz2 or xz).
+ (define %valid-compressors '("gzip" "xz" "none"))
+
+ (let ((compressor-name (compressor-name compressor)))
+ (unless (member compressor-name %valid-compressors)
+ (leave (G_ "~a is not a valid Debian archive compressor. \
+Valid compressors are: ~a~%") compressor-name %valid-compressors)))
+
+ (when entry-point
+ (warning (G_ "entry point not supported in the '~a' format~%")
+ 'deb))
+
+ (define data-tarball
+ (computed-file (string-append "data.tar"
+ (compressor-extension compressor))
+ (self-contained-tarball/builder
+ profile
+ #:profile-name profile-name
+ #:compressor compressor
+ #:localstatedir? localstatedir?
+ #:symlinks symlinks
+ #:archiver archiver)
+ #:local-build? #f ;allow offloading
+ #:options (list #:references-graphs `(("profile" ,profile))
+ #:target target)))
+
+ (define build
+ (with-extensions (list guile-gcrypt)
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ `((guix build pack)
+ (guix build utils)
+ (guix profiles))
+ #:select? not-config?))
+ #~(begin
+ (use-modules (guix build pack)
+ (guix build utils)
+ (guix profiles)
+ (ice-9 match)
+ (srfi srfi-1))
+
+ (define machine-type
+ ;; Extract the machine type from the specified target, else from the
+ ;; current system.
+ (and=> (or #$target %host-type) (lambda (triplet)
+ (first (string-split triplet #\-)))))
+
+ (define (gnu-machine-type->debian-machine-type type)
+ "Translate machine TYPE from the GNU to Debian terminology."
+ ;; Debian has its own jargon, different from the one used in GNU, for
+ ;; machine types (see data/cputable in the sources of dpkg).
+ (match type
+ ("i586" "i386")
+ ("i486" "i386")
+ ("i686" "i386")
+ ("x86_64" "amd64")
+ ("aarch64" "arm64")
+ ("mipsisa32r6" "mipsr6")
+ ("mipsisa32r6el" "mipsr6el")
+ ("mipsisa64r6" "mips64r6")
+ ("mipsisa64r6el" "mips64r6el")
+ ("powerpcle" "powerpcel")
+ ("powerpc64" "ppc64")
+ ("powerpc64le" "ppc64el")
+ (machine machine)))
+
+ (define architecture
+ (gnu-machine-type->debian-machine-type machine-type))
+
+ #$(procedure-source manifest->friendly-name)
+
+ (define manifest (profile-manifest #$profile))
+
+ (define single-entry ;manifest entry
+ (match (manifest-entries manifest)
+ ((entry)
+ entry)
+ (() #f)))
+
+ (define package-name (or (and=> single-entry manifest-entry-name)
+ (manifest->friendly-name manifest)))
+
+ (define package-version
+ (or (and=> single-entry manifest-entry-version)
+ "0.0.0"))
+
+ (define debian-format-version "2.0")
+
+ ;; Generate the debian-binary file.
+ (call-with-output-file "debian-binary"
+ (lambda (port)
+ (format port "~a~%" debian-format-version)))
+
+ (define data-tarball-file-name (strip-store-file-name
+ #+data-tarball))
+
+ (copy-file #+data-tarball data-tarball-file-name)
+
+ (define control-tarball-file-name
+ (string-append "control.tar"
+ #$(compressor-extension compressor)))
+
+ ;; Write the compressed control tarball. Only the control file is
+ ;; mandatory (see: 'man deb' and 'man deb-control').
+ (call-with-output-file "control"
+ (lambda (port)
+ (format port "\
+Package: ~a
+Version: ~a
+Description: Debian archive generated by GNU Guix.
+Maintainer: GNU Guix
+Architecture: ~a
+~%" package-name package-version architecture)))
+
+ (define tar (string-append #+archiver "/bin/tar"))
+
+ (apply invoke tar
+ `(,@(tar-base-options
+ #:tar tar
+ #:compressor '#+(and=> compressor compressor-command))
+ "-cvf" ,control-tarball-file-name
+ "control"))
+
+ ;; Create the .deb archive using GNU ar.
+ (invoke (string-append #+binutils "/bin/ar") "-rv" #$output
+ "debian-binary"
+ control-tarball-file-name data-tarball-file-name)))))
+
+ (gexp->derivation (string-append name ".deb")
+ build
+ #:target target
+ #:references-graphs `(("profile" ,profile))))
+
+
+;;;
;;; Compiling C programs.
;;;
@@ -965,7 +1140,8 @@ last resort for relocation."
;; Supported pack formats.
`((tarball . ,self-contained-tarball)
(squashfs . ,squashfs-image)
- (docker . ,docker-image)))
+ (docker . ,docker-image)
+ (deb . ,debian-archive)))
(define (show-formats)
;; Print the supported pack formats.
@@ -977,6 +1153,8 @@ last resort for relocation."
squashfs Squashfs image suitable for Singularity"))
(display (G_ "
docker Tarball ready for 'docker load'"))
+ (display (G_ "
+ deb Debian archive installable via dpkg/apt"))
(newline))
(define %options
diff --git a/tests/pack.scm b/tests/pack.scm
index ae6247a1d5..9473d4f384 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,6 +33,7 @@
#:use-module ((gnu packages base) #:select (glibc-utf8-locales))
#:use-module (gnu packages bootstrap)
#:use-module ((gnu packages compression) #:select (squashfs-tools))
+ #:use-module ((gnu packages debian) #:select (dpkg))
#:use-module ((gnu packages guile) #:select (guile-sqlite3))
#:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
#:use-module (srfi srfi-64))
@@ -56,6 +58,8 @@
(define %tar-bootstrap %bootstrap-coreutils&co)
+(define %ar-bootstrap %bootstrap-binutils)
+
(test-begin "pack")
@@ -270,6 +274,77 @@
1)
(pk 'guilelink (readlink "bin"))))
(mkdir #$output))))))))
+ (built-derivations (list check))))
+
+ (unless store (test-skip 1))
+ (test-assertm "deb archive with symlinks" store
+ (mlet* %store-monad
+ ((guile (set-guile-for-build (default-guile)))
+ (profile (profile-derivation (packages->manifest
+ (list %bootstrap-guile))
+ #:hooks '()
+ #:locales? #f))
+ (deb (debian-archive "deb-pack" profile
+ #:compressor %gzip-compressor
+ #:symlinks '(("/opt/gnu/bin" -> "bin"))
+ #:archiver %tar-bootstrap))
+ (check
+ (gexp->derivation "check-deb-pack"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 match)
+ (ice-9 popen)
+ (ice-9 rdelim)
+ (ice-9 textual-ports)
+ (rnrs base))
+
+ (setenv "PATH" (string-join
+ (list (string-append #+%tar-bootstrap "/bin")
+ (string-append #+dpkg "/bin")
+ (string-append #+%ar-bootstrap "/bin"))
+ ":"))
+
+ ;; Validate the output of 'dpkg --info'.
+ (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb))
+ (info (get-string-all port))
+ (exit-val (status:exit-val (close-pipe port))))
+ (assert (zero? exit-val))
+
+ (assert (string-contains
+ info
+ (string-append "Package: "
+ #+(package-name %bootstrap-guile))))
+
+ (assert (string-contains
+ info
+ (string-append "Version: "
+ #+(package-version %bootstrap-guile)))))
+
+ ;; Sanity check .deb contents.
+ (invoke "ar" "-xv" #$deb)
+ (assert (file-exists? "debian-binary"))
+ (assert (file-exists? "data.tar.gz"))
+ (assert (file-exists? "control.tar.gz"))
+
+ ;; Verify there are no hard links in data.tar.gz, as hard
+ ;; links would cause dpkg to fail unpacking the archive.
+ (define hard-links
+ (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz")))
+ (let loop ((hard-links '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (assert (zero? (status:exit-val (close-pipe port))))
+ hard-links)
+ (line
+ (if (string-prefix? "u" line)
+ (loop (cons line hard-links))
+ (loop hard-links)))))))
+
+ (unless (null? hard-links)
+ (error "hard links found in data.tar.gz" hard-links))
+
+ (mkdir #$output))))))
(built-derivations (list check)))))
(test-end)