[bug#49149] [PATCH v2 7/7] pack: Add support for the deb format.

[Maxim Cournoyer]

* .dir-locals.el (scheme-mode)[gexp->derivation]: Define indentation rule.
* guix/scripts/pack.scm (debian-archive): New procedure.
(%formats): Register the new deb format.
(show-formats): Add it to the usage string.
* tests/pack.scm (%ar-bootstrap): New variable.
(deb archive with symlinks): New test.
* doc/guix.texi (Invoking guix pack): Document it.
---
 .dir-locals.el        |   1 +
 doc/guix.texi         |   5 ++
 guix/scripts/pack.scm | 178 +++++++++++++++++++++++++++++++++++++++++-
 tests/pack.scm        |  75 ++++++++++++++++++
 4 files changed, 258 insertions(+), 1 deletion(-)

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/doc/guix.texi b/doc/guix.texi
index 15e8999447..70de6b16ae 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6025,6 +6025,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 symlinks, 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 84f2f14343..7de061d7ae 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")
@@ -633,6 +647,165 @@ the image."
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
 
+
+;;;
+;;; 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
+                ("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 +1138,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 +1151,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)
-- 
2.32.0