ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

pack: Add support for the deb format.

Browse source 
* .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.
* NEWS: Add news entry.
This commit is contained in:
Maxim Cournoyer 2021-06-15 10:21:50 -04:00
parent 8108c266dc
commit 82daab4281
No known key found for this signature in database
GPG key ID: 1260E46482E63562
5 changed files with 265 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.dir-locals.el
View file

@ -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))

7
NEWS
View file

@ -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’

5
doc/guix.texi
View file

@ -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

180
guix/scripts/pack.scm
View file

@ -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 @@ (define-module (guix scripts pack)
%compressors
lookup-compressor
self-contained-tarball
debian-archive
docker-image
squashfs-image
@ -346,6 +348,10 @@ (define* (self-contained-tarball name profile
#: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 @@ (define build
(computed-file "singularity-environment.sh" build))
;;;
;;; SquashFS image format.
;;;
(define* (squashfs-image name profile
#:key target
(profile-name "guix-profile")
@ -546,6 +556,10 @@ (define (mksquashfs args)
#:target target
#:references-graphs `(("profile" ,profile))))
;;;
;;; Docker image format.
;;;
(define* (docker-image name profile
#:key target
(profile-name "guix-profile")
@ -633,6 +647,167 @@ (define directives
#: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
("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 @@ (define %formats
;; 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 @@ (define (show-formats)
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

75
tests/pack.scm
View file

@ -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 @@ (define-module (test-pack)
#: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 %gzip-compressor
(define %tar-bootstrap %bootstrap-coreutils&co)
(define %ar-bootstrap %bootstrap-binutils)
(test-begin "pack")
@ -270,6 +274,77 @@ (define bin
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)