From patchwork Mon Jun 21 06:12:05 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Maxim Cournoyer X-Patchwork-Id: 30565 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 91C8C27BC81; Mon, 21 Jun 2021 07:13:34 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2, SPF_HELO_PASS,T_DKIM_INVALID,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id AE01727BC78 for ; Mon, 21 Jun 2021 07:13:33 +0100 (BST) Received: from localhost ([::1]:39290 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lvDBc-0008WA-PA for patchwork@mira.cbaines.net; Mon, 21 Jun 2021 02:13:32 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:47952) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lvDBB-0007yF-JG for guix-patches@gnu.org; Mon, 21 Jun 2021 02:13:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:51899) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lvDBB-0001uT-AI for guix-patches@gnu.org; Mon, 21 Jun 2021 02:13:05 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lvDBB-0006dA-6I for guix-patches@gnu.org; Mon, 21 Jun 2021 02:13:05 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49149] [PATCH 7/7] pack: Add support for the deb format. Resent-From: Maxim Cournoyer Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 21 Jun 2021 06:13:05 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49149 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49149@debbugs.gnu.org Cc: Maxim Cournoyer Received: via spool by 49149-submit@debbugs.gnu.org id=B49149.162425598125427 (code B ref 49149); Mon, 21 Jun 2021 06:13:05 +0000 Received: (at 49149) by debbugs.gnu.org; 21 Jun 2021 06:13:01 +0000 Received: from localhost ([127.0.0.1]:35205 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvDB6-0006c2-NT for submit@debbugs.gnu.org; Mon, 21 Jun 2021 02:13:01 -0400 Received: from mail-qv1-f46.google.com ([209.85.219.46]:34686) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lvDAx-0006aj-Qh for 49149@debbugs.gnu.org; Mon, 21 Jun 2021 02:12:53 -0400 Received: by mail-qv1-f46.google.com with SMTP id 5so6884565qvf.1 for <49149@debbugs.gnu.org>; Sun, 20 Jun 2021 23:12:51 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=cP3aVdwN3atijV5JRtQpUyf/pI33KDNEeFpdCFMprWc=; b=SHl1eQKVHKqVuPd/9sH+dgMrG0gkbG6Onx4fQTcAGIb5igKOvLrNdRka+StdZc7E6P Snhp6sioe1DE+rsueqH+infWtBVI8pc3h3l2OrxsDHRIJd/IbWRS7ReFV3coDJcoxp/x CdG/WQWV3NZo4sbeykboIUfETixFX/gHCefzPvtsuow6g/n1cMHOKEJUM6c/RPcb3G1/ A63LJy7lixIwnCyk9M+hlHU2GeIcfMdnkEH9D2woQGDwAx9ohGIysPgQNlnCJ9Ce7W7H txdh8/vlVDh1OVibepWS1gJGlBAsMS+s4ROkW6id/aphkx1XmYxTYA0+FXNNZjpb4iQ1 ++wA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=cP3aVdwN3atijV5JRtQpUyf/pI33KDNEeFpdCFMprWc=; b=d9fuPxi4f5ITPgEfnC7ZG6LJ3TkjaLyuVepNcGAZIle0RpQcYG2CZkhlV/IVwI149W f+w4DBoXax33Fd6mbG9qsYFHQxvA+Ha3NBt+wAsNnRTG8kF++nAkXXlV4ZRWEOWJKrEz 37RFuc7/eK3VBnaHYQJG5fdYKxv7tvW0lhs8ztFOvtrDTusm8bD/B0wheG+vLbj8Czt9 /dQ/ldm/T0v5azkjI/1yN/ohBKQ+75Uum/lNBsHPAclhmq4ypb0tQVxSlU/q0AzLMq66 +OsaC+2eVH777g5f5jG9IbRKEwS2KTx53yDoOXjIhv/Vknj8063olF26zQSFGsNAjDea weUA== X-Gm-Message-State: AOAM532WJgQUGgoukN78BhRtCpa6k4iV3MevupwA6MxTf2Toa31oaYPv nyT6ejx6J5R8afASZHjePCedIvKzTJ8Kjw== X-Google-Smtp-Source: ABdhPJxx/HJsl7t9dofjGf0B6ZlvfzWbdezhMM/bJtiNAriTHBN5cAzbihvCJocC711Rkkgv5aUkdg== X-Received: by 2002:ad4:4e47:: with SMTP id eb7mr18596338qvb.8.1624255966170; Sun, 20 Jun 2021 23:12:46 -0700 (PDT) Received: from localhost.localdomain (dsl-148-219.b2b2c.ca. [66.158.148.219]) by smtp.gmail.com with ESMTPSA id i11sm8478663qke.74.2021.06.20.23.12.45 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 20 Jun 2021 23:12:45 -0700 (PDT) From: Maxim Cournoyer Date: Mon, 21 Jun 2021 02:12:05 -0400 Message-Id: <20210621061205.31878-8-maxim.cournoyer@gmail.com> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210621061205.31878-1-maxim.cournoyer@gmail.com> References: <20210621061205.31878-1-maxim.cournoyer@gmail.com> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * .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 0930a514c7..7fb8d8e9d2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6016,6 +6016,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 8a108b7a1a..18f003dec0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; Copyright © 2020 Eric Bavier +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -65,6 +66,7 @@ %compressors lookup-compressor self-contained-tarball + debian-archive docker-image squashfs-image @@ -341,6 +343,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." @@ -367,6 +373,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") @@ -541,6 +551,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") @@ -628,6 +642,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)) + + #$define-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. @@ -960,7 +1133,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. @@ -972,6 +1146,8 @@ last resort for relocation." squashfs Squashfs image suitable for Singularity")) (display (G_ " docker Tarball ready for 'docker load'")) + (display (G_ " + deb Debian archive compatible, installable via dpkg/apt")) (newline)) (define %options diff --git a/tests/pack.scm b/tests/pack.scm index ae6247a1d5..ed461c6887 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 ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; 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 (pk 'line (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)