From dfac3e643a924ccefc997b4433a0b5c35928d657 Mon Sep 17 00:00:00 2001 From: Philip Munksgaard Date: Fri, 18 Jun 2021 14:48:13 +0200 Subject: import: hackage: Support "common" field and imports MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/import/cabal.scm (make-cabal-parser): Modify. (is-common): New variable. (lex-common): New procedure. (is-id): Modify. (eval-cabal): Modify. * tests/hackage.scm ("hackage->guix-package test cabal import") New test. Signed-off-by: Ludovic Courtès --- tests/hackage.scm | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) (limited to 'tests') diff --git a/tests/hackage.scm b/tests/hackage.scm index 66a13d9881..53972fc643 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -388,4 +388,46 @@ executable cabal #t) (x (pk 'fail x #f)))) +(define test-cabal-import + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +common commons + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 + +executable cabal + import: commons +") + +(define-package-matcher match-ghc-foo-import + ('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-http" ('unquote 'ghc-http))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'license:bsd-3))) + +(test-assert "hackage->guix-package test cabal import" + (eval-test-with-cabal test-cabal-import match-ghc-foo-import)) + (test-end "hackage") -- cgit 1.4.1 From 2ad896751c8f7104f139c3fd43cd632fd428ccd5 Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Sat, 12 Jun 2021 21:17:08 +0200 Subject: services: configuration: Allow specifying prefix for serializer names. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Sometimes two configurations might have the same types for their field values, but the values might be serialized in two completely different ways (e.g. because the two programs have different configuration languages). An example of this would be the ‘serialize-boolean’ procedure in (gnu services mail) and (gnu services getmail). They both serialize a boolean value, but because the Dovecot’s configuration language has a different syntax to the configuration language for Getmail, two different procedures have to be defined. One way to workaround this would be to specify custom serializers for many fields in order to separate the serialization of the values that have the same type but serialize in different ways. This could get very tedious, especially if there are many configurations in the same module. Another way would be to move one of the configurations to its own module, like what was done with (gnu services getmail). However, this would mean that there would be multiple modules containing configurations for related programs, e.g. we have (gnu services mail) and (gnu services getmail), it doesn’t make much sense to keep the Getmail configuration in its own module. This patch will allow one to write something like this: (define-configuration foo-configuration (bar (string "bob") "Option bar.") (prefix bar-)) and the value of the ‘bar’ field would be serialized using a procedure named ‘bar-serialize-string’ instead of just ‘serialize-string’. * gnu/services/configuration.scm (define-maybe-helper): Accept ‘prefix’ argument for using serializer with custom prefix. (define-maybe): Pattern match on ‘prefix’ literal. (define-configuration-helper): Accept ‘prefix’ argument for using serializer with custom prefix. (define-configuration): Pattern match on ‘prefix’ literal. * tests/services/configuration.scm ("serialize-configuration with prefix"): New test. Signed-off-by: Ludovic Courtès --- gnu/services/configuration.scm | 38 +++++++++++++++++++++++++++----------- tests/services/configuration.scm | 12 ++++++++++++ 2 files changed, 39 insertions(+), 11 deletions(-) (limited to 'tests') diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index f23840ee6d..fd07b6fa49 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -109,14 +109,18 @@ does not have a default value" field kind))) "Assemble PARTS into a raw (unhygienic) identifier." (datum->syntax ctx (symbol-append (syntax->datum parts) ...))) -(define (define-maybe-helper serialize? syn) +(define (define-maybe-helper serialize? prefix syn) (syntax-case syn () ((_ stem) (with-syntax ((stem? (id #'stem #'stem #'?)) (maybe-stem? (id #'stem #'maybe- #'stem #'?)) - (serialize-stem (id #'stem #'serialize- #'stem)) - (serialize-maybe-stem (id #'stem #'serialize-maybe- #'stem))) + (serialize-stem (if prefix + (id #'stem prefix #'serialize- #'stem) + (id #'stem #'serialize- #'stem))) + (serialize-maybe-stem (if prefix + (id #'stem prefix #'serialize-maybe- #'stem) + (id #'stem #'serialize-maybe- #'stem)))) #`(begin (define (maybe-stem? val) (or (eq? val 'disabled) (stem? val))) @@ -129,16 +133,18 @@ does not have a default value" field kind))) (define-syntax define-maybe (lambda (x) - (syntax-case x (no-serialization) + (syntax-case x (no-serialization prefix) ((_ stem (no-serialization)) - (define-maybe-helper #f #'(_ stem))) + (define-maybe-helper #f #f #'(_ stem))) + ((_ stem (prefix serializer-prefix)) + (define-maybe-helper #t #'serializer-prefix #'(_ stem))) ((_ stem) - (define-maybe-helper #t #'(_ stem)))))) + (define-maybe-helper #t #f #'(_ stem)))))) (define-syntax-rule (define-maybe/no-serialization stem) (define-maybe stem (no-serialization))) -(define (define-configuration-helper serialize? syn) +(define (define-configuration-helper serialize? serializer-prefix syn) (syntax-case syn () ((_ stem (field (field-type def ...) doc custom-serializer ...) ...) (with-syntax (((field-getter ...) @@ -165,7 +171,11 @@ does not have a default value" field kind))) ((serializer) serializer) (() - (id #'stem #'serialize- type))))) + (if serializer-prefix + (id #'stem + serializer-prefix + #'serialize- type) + (id #'stem #'serialize- type)))))) #'(field-type ...) #'((custom-serializer ...) ...)))) #`(begin @@ -212,15 +222,21 @@ does not have a default value" field kind))) (define-syntax define-configuration (lambda (s) - (syntax-case s (no-serialization) + (syntax-case s (no-serialization prefix) ((_ stem (field (field-type def ...) doc custom-serializer ...) ... (no-serialization)) (define-configuration-helper - #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) + #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) + ...))) + ((_ stem (field (field-type def ...) doc custom-serializer ...) ... + (prefix serializer-prefix)) + (define-configuration-helper + #t #'serializer-prefix #'(_ stem (field (field-type def ...) + doc custom-serializer ...) ...))) ((_ stem (field (field-type def ...) doc custom-serializer ...) ...) (define-configuration-helper - #t #'(_ stem (field (field-type def ...) doc custom-serializer ...) + #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) ...)))))) (define-syntax-rule (define-configuration/no-serialization diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 85badd2da6..86a36a388d 100644 --- a/tests/services/configuration.scm +++ b/tests/services/configuration.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,17 @@ (let ((config (serializable-configuration))) (serialize-configuration config serializable-configuration-fields))))) +(define (custom-prefix-serialize-integer field-name name) name) + +(define-configuration configuration-with-prefix + (port (integer 10) "The port number.") + (prefix custom-prefix-)) + +(test-assert "serialize-configuration with prefix" + (gexp? + (let ((config (configuration-with-prefix))) + (serialize-configuration config configuration-with-prefix-fields)))) + ;;; ;;; define-maybe macro. -- cgit 1.4.1 From 4f3bdc8f21657dbda857027b3ec8754dd4c7c67b Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 01:22:35 -0400 Subject: pack: Prevent duplicate files in tar archives. Tar translate duplicate files in the archive into hard links. These can cause problems, as not every tool support them; for example dpkg doesn't. * gnu/system/file-systems.scm (reduce-directories): New procedure. (file-prefix?): Lift the restriction on file prefix. The procedure can be useful for comparing relative file names. Adjust doc. (file-name-depth): New procedure, extracted from ... (btrfs-store-subvolume-file-name): ... here. * guix/scripts/pack.scm (self-contained-tarball/builder): Use reduce-directories. * tests/file-systems.scm ("reduce-directories"): New test. --- gnu/system/file-systems.scm | 56 ++++++++++++++++++++++++++++++--------------- guix/scripts/pack.scm | 6 +++-- tests/file-systems.scm | 7 +++++- 3 files changed, 48 insertions(+), 21 deletions(-) (limited to 'tests') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 464e87cb18..fb87bfc85b 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,6 +55,7 @@ file-system-dependencies file-system-location + reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -231,8 +232,8 @@ (char-set-complement (char-set #\/))) (define (file-prefix? file1 file2) - "Return #t if FILE1 denotes the name of a file that is a parent of FILE2, -where both FILE1 and FILE2 are absolute file name. For example: + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2. +For example: (file-prefix? \"/gnu\" \"/gnu/store\") => #t @@ -240,19 +241,41 @@ where both FILE1 and FILE2 are absolute file name. For example: (file-prefix? \"/gn\" \"/gnu/store\") => #f " - (and (string-prefix? "/" file1) - (string-prefix? "/" file2) - (let loop ((file1 (string-tokenize file1 %not-slash)) - (file2 (string-tokenize file2 %not-slash))) - (match file1 - (() - #t) - ((head1 tail1 ...) - (match file2 - ((head2 tail2 ...) - (and (string=? head1 head2) (loop tail1 tail2))) - (() - #f))))))) + (let loop ((file1 (string-tokenize file1 %not-slash)) + (file2 (string-tokenize file2 %not-slash))) + (match file1 + (() + #t) + ((head1 tail1 ...) + (match file2 + ((head2 tail2 ...) + (and (string=? head1 head2) (loop tail1 tail2))) + (() + #f)))))) + +(define (file-name-depth file-name) + (length (string-tokenize file-name %not-slash))) + +(define (reduce-directories file-names) + "Eliminate entries in FILE-NAMES that are children of other entries in +FILE-NAMES. This is for example useful when passing a list of files to GNU +tar, which would otherwise descend into each directory passed and archive the +duplicate files as hard links, which can be undesirable." + (let* ((file-names/sorted + ;; Ascending sort by file hierarchy depth, then by file name length. + (stable-sort (delete-duplicates file-names) + (lambda (f1 f2) + (let ((depth1 (file-name-depth f1)) + (depth2 (file-name-depth f2))) + (if (= depth1 depth2) + (string< f1 f2) + (< depth1 depth2))))))) + (reverse (fold (lambda (file-name results) + (if (find (cut file-prefix? <> file-name) results) + results ;parent found -- skipping + (cons file-name results))) + '() + file-names/sorted)))) (define* (file-system-device->string device #:key uuid-type) "Return the string representations of the DEVICE field of a @@ -624,9 +647,6 @@ store is located, else #f." s (string-append "/" s))) - (define (file-name-depth file-name) - (length (string-tokenize file-name %not-slash))) - (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems)) (btrfs-subvolume-fs* (sort btrfs-subvolume-fs diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 952c1455be..cee1444110 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -230,13 +230,15 @@ its source property." `((guix build pack) (guix build utils) (guix build union) - (gnu build install)) + (gnu build install) + (gnu system file-systems)) #:select? import-module?) #~(begin (use-modules (guix build pack) (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) + ((gnu system file-systems) #:select (reduce-directories)) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -303,7 +305,7 @@ its source property." ,(string-append "." (%store-directory)) - ,@(delete-duplicates + ,@(reduce-directories (filter-map (match-lambda (('directory directory) (string-append "." directory)) diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 7f7c373884..80acb6d5b9 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès -;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,6 +50,11 @@ (device "/foo") (flags '(bind-mount read-only))))))))) +(test-equal "reduce-directories" + '("./opt/gnu/" "./opt/gnuism" "a/b/c") + (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin" + "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c"))) + (test-assert "does not pull (guix config)" ;; This module is meant both for the host side and "build side", so make ;; sure it doesn't pull in (guix config), which depends on the user's -- cgit 1.4.1 From 8108c266dc2fbc70602b2aa5c6887bf17bed16e8 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 21 Jun 2021 01:10:40 -0400 Subject: tests: pack: Fix compressor extension. * tests/pack.scm (%gzip-compressor): Add the missing leading period to the gzip compressor file extension. --- tests/pack.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/pack.scm b/tests/pack.scm index e8455b4f37..ae6247a1d5 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -51,7 +51,7 @@ (define %gzip-compressor ;; Compressor that uses the bootstrap 'gzip'. ((@ (guix scripts pack) compressor) "gzip" - "gz" + ".gz" #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) (define %tar-bootstrap %bootstrap-coreutils&co) -- cgit 1.4.1 From 82daab42811a2e3c7684ebdf12af75ff0fa67b99 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 15 Jun 2021 10:21:50 -0400 Subject: pack: Add support for the deb format. * .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. --- .dir-locals.el | 1 + NEWS | 7 +- doc/guix.texi | 5 ++ guix/scripts/pack.scm | 180 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/pack.scm | 75 +++++++++++++++++++++ 5 files changed, 265 insertions(+), 3 deletions(-) (limited to 'tests') 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 Copyright © 2016, 2017, 2018 Ricardo Wurmus +Copyright © 2021 Maxim Cournoyer 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 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 ;;; 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 @@ -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,167 @@ 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 + ("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 ;;; 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 (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) -- cgit 1.4.1 From d9e0ae07db5cb9f949c11f4ee77146a070c2618c Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 28 Jun 2021 19:24:44 +0200 Subject: guix: gexp: Define gexp->approximate-sexp. It will be used in the 'optional-tests' linter. * guix/gexp.scm (gexp->approximate-sexp): New procedure. * tests/gexp.scm ("no references", "unquoted gexp", "unquoted gexp (native)") ("spliced gexp", "unspliced gexp, approximated") ("unquoted gexp, approximated"): Test it. * doc/gexp.scm ("G-Expressions"): Document it. Signed-off-by: Mathieu Othacehe --- doc/guix.texi | 10 ++++++++++ guix/gexp.scm | 19 +++++++++++++++++++ tests/gexp.scm | 31 +++++++++++++++++++++++++++++++ 3 files changed, 60 insertions(+) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index e0668b1f5f..e39e4eb7be 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10046,6 +10046,16 @@ corresponding to @var{obj} for @var{system}, cross-compiling for has an associated gexp compiler, such as a @code{}. @end deffn +@deffn {Procedure} gexp->approximate-sexp @var{gexp} +Sometimes, it may be useful to convert a G-exp into a S-exp. For +example, some linters (@pxref{Invoking guix lint}) peek into the build +phases of a package to detect potential problems. This conversion can +be achieved with this procedure. However, some information can be lost +in the process. More specifically, lowerable objects will be silently +replaced with some arbitrary object -- currently the list +@code{(*approximate*)}, but this may change. +@end deffn + @node Invoking guix repl @section Invoking @command{guix repl} diff --git a/guix/gexp.scm b/guix/gexp.scm index 187f5c5e85..f3d278b3e6 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +43,7 @@ with-imported-modules with-extensions let-system + gexp->approximate-sexp gexp-input gexp-input? @@ -157,6 +159,23 @@ "Return the source code location of GEXP." (and=> (%gexp-location gexp) source-properties->location)) +(define* (gexp->approximate-sexp gexp) + "Return the S-expression corresponding to GEXP, but do not lower anything. +As a result, the S-expression will be approximate if GEXP has references." + (define (gexp-like? thing) + (or (gexp? thing) (gexp-input? thing))) + (apply (gexp-proc gexp) + (map (lambda (reference) + (match reference + (($ thing output native) + (if (gexp-like? thing) + (gexp->approximate-sexp thing) + ;; Simply returning 'thing' won't work in some + ;; situations; see 'write-gexp' below. + '(*approximate*))) + (_ '(*approximate*)))) + (gexp-references gexp)))) + (define (write-gexp gexp port) "Write GEXP on PORT." (display "# +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -89,6 +90,36 @@ (test-begin "gexp") +(test-equal "no references" + '(display "hello gexp->approximate-sexp!") + (gexp->approximate-sexp #~(display "hello gexp->approximate-sexp!"))) + +(test-equal "unquoted gexp" + '(display "hello") + (let ((inside #~"hello")) + (gexp->approximate-sexp #~(display #$inside)))) + +(test-equal "unquoted gexp (native)" + '(display "hello") + (let ((inside #~"hello")) + (gexp->approximate-sexp #~(display #+inside)))) + +(test-equal "spliced gexp" + '(display '(fresh vegetables)) + (let ((inside #~(fresh vegetables))) + (gexp->approximate-sexp #~(display '(#$@inside))))) + +(test-equal "unspliced gexp, approximated" + ;; (*approximate*) is really an implementation detail + '(display '(*approximate*)) + (let ((inside (file-append coreutils "/bin/hello"))) + (gexp->approximate-sexp #~(display '(#$@inside))))) + +(test-equal "unquoted gexp, approximated" + '(display '(*approximate*)) + (let ((inside (file-append coreutils "/bin/hello"))) + (gexp->approximate-sexp #~(display '#$inside)))) + (test-equal "no refs" '(display "hello!") (let ((exp (gexp (display "hello!")))) -- cgit 1.4.1 From 5532371a3a25adaa023a00ae1004c2f422f3abc8 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 28 Jun 2021 20:44:16 +0200 Subject: lint: Verify if #:tests? is respected in the 'check' phase. There have been a few patches to the mailing list lately not respecting this, and this linter detects 630 package definitions that could be modified to support the --without-tests package transformation. * guix/lint.scm (check-optional-tests): New linter. (%local-checkers)[optional-tests]: Add it. * tests/lint.scm (package-with-phase-changes): New procedure. ("optional-tests: no check phase") ("optional-tests: check hase respects #:tests?") ("optional-tests: check phase ignores #:tests?") ("optional-tests: do not crash when #:phases is invalid") ("optional-tests: allow G-exps (no warning)") ("optional-tests: allow G-exps (warning)") ("optional-tests: complicated 'check' phase") ("optional-tests: 'check' phase is not first phase"): New tests. Signed-off-by: Mathieu Othacehe --- guix/lint.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++- tests/lint.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 135 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/guix/lint.scm b/guix/lint.scm index 70ed677a54..1f48bcc454 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -40,7 +40,8 @@ #:use-module (guix packages) #:use-module (guix i18n) #:use-module ((guix gexp) - #:select (local-file? local-file-absolute-file-name)) + #:select (gexp? local-file? local-file-absolute-file-name + gexp->approximate-sexp)) #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix grafts) @@ -89,6 +90,7 @@ check-source check-source-file-name check-source-unstable-tarball + check-optional-tests check-mirror-url check-github-url check-license @@ -1098,6 +1100,58 @@ descriptions maintained upstream." (define exception-with-kind-and-args? (exception-predicate &exception-with-kind-and-args)) +(define (check-optional-tests package) + "Emit a warning if the test suite is run unconditionally." + (define (sexp-contains-atom? sexp atom) + "Test if SEXP contains ATOM." + (if (pair? sexp) + (or (sexp-contains-atom? (car sexp) atom) + (sexp-contains-atom? (cdr sexp) atom)) + (eq? sexp atom))) + (define (sexp-uses-tests?? sexp) + "Test if SEXP contains the symbol 'tests?'." + (sexp-contains-atom? sexp 'tests?)) + (define (check-check-procedure expression) + (match expression + (`(,(or 'let 'let*) . ,_) + (check-check-procedure (car (last-pair expression)))) + (`(,(or 'lambda 'lambda*) ,_ . ,code) + (if (sexp-uses-tests?? code) + '() + (list (make-warning package + ;; TRANSLATORS: check and #:tests? are a + ;; Scheme symbol and keyword respectively + ;; and should not be translated. + (G_ "the 'check' phase should respect #:tests?") + #:field 'arguments)))) + (_ '()))) + (define (check-phases-delta delta) + (match delta + (`(replace 'check ,expression) + (check-check-procedure expression)) + (_ '()))) + (define (check-phases-deltas deltas) + (match deltas + (() '()) + ((head . tail) + (append (check-phases-delta head) + (check-phases-deltas tail))) + (_ (list (make-warning package + ;; TRANSLATORS: modify-phases is a Scheme + ;; syntax and must not be translated. + (G_ "incorrect call to ‘modify-phases’") + #:field 'arguments))))) + (apply (lambda* (#:key phases #:allow-other-keys) + (define phases/sexp + (if (gexp? phases) + (gexp->approximate-sexp phases) + phases)) + (match phases/sexp + (`(modify-phases ,_ . ,changes) + (check-phases-deltas changes)) + (_ '()))) + (package-arguments package))) + (define* (check-derivation package #:key store) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try store system) @@ -1598,6 +1652,10 @@ them for PACKAGE." (description "Make sure the 'license' field is a \ or a list thereof") (check check-license)) + (lint-checker + (name 'optional-tests) + (description "Make sure tests are only run when requested") + (check check-optional-tests)) (lint-checker (name 'mirror-url) (description "Suggest 'mirror://' URLs") diff --git a/tests/lint.scm b/tests/lint.scm index fae346e724..4ef400a9a0 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2018, 2019 Arun Isaac ;;; Copyright © 2020 Timothy Sample ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +39,7 @@ #:use-module (guix lint) #:use-module (guix ui) #:use-module (guix swh) - #:use-module ((guix gexp) #:select (local-file)) + #:use-module ((guix gexp) #:select (gexp local-file gexp?)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix import hackage) #:select (%hackage-url)) #:use-module ((guix import stackage) #:select (%stackage-url)) @@ -744,6 +745,80 @@ (sha256 %null-sha256)))))) (check-source-unstable-tarball pkg))) +(define (package-with-phase-changes changes) + (dummy-package "x" + (arguments `(#:phases + ,(if (gexp? changes) + #~(modify-phases %standard-phases + #$@changes) + `(modify-phases %standard-phases + ,@changes)))))) + +(test-equal "optional-tests: no check phase" + '() + (let ((pkg (package-with-phase-changes '()))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: check phase respects #:tests?" + '() + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda* (#:key tests? #:allow-other-keys?) + (when tests? + (invoke "./the-test-suite")))))))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: check phase ignores #:tests?" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda _ + (invoke "./the-test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: do not crash when #:phases is invalid" + "incorrect call to ‘modify-phases’" + (let ((pkg (package-with-phase-changes 'this-is-not-a-list))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: allow G-exps (no warning)" + '() + (let ((pkg (package-with-phase-changes #~()))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: allow G-exps (warning)" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + #~((replace 'check + (lambda _ + (invoke "/the-test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: complicated 'check' phase" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda* (#:key inputs tests? #:allow-other-keys) + (let ((something (stuff from inputs or native-inputs))) + (delete-file "dateutil/test/test_utils.py") + (invoke "pytest" "-vv")))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: 'check' phase is not first phase" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((add-after 'unpack + (lambda _ + (chdir "libtestcase-0.0.0"))) + (replace 'check + (lambda _ (invoke "./test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + (test-equal "source: 200" '() (with-http-server `((200 ,%long-string)) -- cgit 1.4.1 From eac82c0e0a9f5afb5452928acf9b84cbc019c81c Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Thu, 1 Jul 2021 12:59:52 +0200 Subject: lint: Lint usages of 'wrap-program' without a "bash" input. When using 'wrap-program', "bash" (or "bash-minimal") should be in inputs. Otherwise, when cross-compiling, 'wrap-program' will use a native bash instead of the cross bash and the 'patch-shebangs' won't be able to correct this. Tobias Geerinckx-Rice is added to the copyright lines because a part of the "straw-viewer" package definition is included. This linter detects 365 problematic package definitions at time of writing. * guix/lint.scm (report-wrap-program-error): New procedure. (check-wrapper-inputs): New linter. (%local-checkers)[wrapper-inputs]: Add the new linter. ("explicit #:sh argument to 'wrap-program' is acceptable") ("'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs") ("'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs") ("\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'") ("\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'") ("'cut' doesn't hide bad usages of 'wrap-program'") ("bogus phase specifications don't crash the linter"): New tests. Signed-off-by: Mathieu Othacehe --- guix/lint.scm | 48 ++++++++++++++++++++++++++++++++ tests/lint.scm | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 136 insertions(+) (limited to 'tests') diff --git a/guix/lint.scm b/guix/lint.scm index 5125b7722c..8f31de041d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -81,6 +81,7 @@ #:export (check-description-style check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all + check-wrapper-inputs check-patch-file-names check-patch-headers check-synopsis-style @@ -491,6 +492,49 @@ of a package, and INPUT-NAMES, a list of package specifications such as (package-input-intersection (package-direct-inputs package) input-names)))) +(define (report-wrap-program-error package wrapper-name) + "Warn that \"bash-minimal\" is missing from 'inputs', while WRAPPER-NAME +requires it." + (make-warning package + (G_ "\"bash-minimal\" should be in 'inputs' when '~a' is used") + (list wrapper-name))) + +(define (check-wrapper-inputs package) + "Emit a warning if PACKAGE uses 'wrap-program' or similar, but \"bash\" +or \"bash-minimal\" is not in its inputs. 'wrap-script' is not supported." + (define input-names '("bash" "bash-minimal")) + (define has-bash-input? + (pair? (package-input-intersection (package-inputs package) + input-names))) + (define (check-procedure-body body) + (match body + ;; Explicitely setting an interpreter is acceptable, + ;; #:sh support is added on 'core-updates'. + ;; TODO(core-updates): remove mention of core-updates. + (('wrap-program _ '#:sh . _) '()) + (('wrap-program _ . _) + (list (report-wrap-program-error package 'wrap-program))) + ;; Wrapper of 'wrap-program' for Qt programs. + ;; TODO #:sh is not yet supported but probably will be. + (('wrap-qt-program _ '#:sh . _) '()) + (('wrap-qt-program _ . _) + (list (report-wrap-program-error package 'wrap-qt-program))) + ((x . y) + (append (check-procedure-body x) (check-procedure-body y))) + (_ '()))) + (define (check-phase-procedure expression) + (find-procedure-body expression check-procedure-body)) + (define (check-delta expression) + (find-phase-procedure package expression check-phase-procedure)) + (define (check-deltas deltas) + (append-map check-delta deltas)) + (if has-bash-input? + ;; "bash" (or "bash-minimal") is in 'inputs', so everything seems ok. + '() + ;; "bash" is not in 'inputs'. Verify 'wrap-program' and friends + ;; are unused + (find-phase-deltas package check-deltas))) + (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a line." @@ -1696,6 +1740,10 @@ them for PACKAGE." (name 'inputs-should-not-be-input) (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker + (name 'wrapper-inputs) + (description "Make sure 'wrap-program' can finds its interpreter.") + (check check-wrapper-inputs)) (lint-checker (name 'license) ;; TRANSLATORS: is the name of a data type and must not be diff --git a/tests/lint.scm b/tests/lint.scm index 4ef400a9a0..82971db8f0 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Efraim Flashner ;;; Copyright © 2018, 2019 Arun Isaac ;;; Copyright © 2020 Timothy Sample +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Maxime Devos ;;; @@ -47,6 +48,7 @@ #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python-xyz) + #:use-module ((gnu packages bash) #:select (bash bash-minimal)) #:use-module (web uri) #:use-module (web server) #:use-module (web server http) @@ -357,6 +359,92 @@ `(("python-setuptools" ,python-setuptools)))))) (check-inputs-should-not-be-an-input-at-all pkg)))) +(test-equal "explicit #:sh argument to 'wrap-program' is acceptable" + '() + (let* ((phases + ;; Loosely based on the "catfish" package + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda* (#:key inputs outputs #:allow-other-keys) + (define catfish (string-append (assoc-ref outputs "out") + "/bin/catfish")) + (define hsab (string-append (assoc-ref inputs "hsab") + "/bin/hsab")) + (wrap-program catfish #:sh hsab + `("PYTHONPATH" = (,"blabla"))))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (check-wrapper-inputs pkg))) + +(test-equal + "'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs" + "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used" + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal + "'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs" + "\"bash-minimal\" should be in 'inputs' when 'wrap-qt-program' is used" + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'qtwrap + (lambda _ + (wrap-qt-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal "\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'" + '() + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases)) + (inputs `(("bash" ,bash)))))) + (check-wrapper-inputs pkg))) + +(test-equal "\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'" + '() + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program THE-BINARY bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases)) + (inputs `(("bash-minimal" ,bash-minimal)))))) + (check-wrapper-inputs pkg))) + +(test-equal "'cut' doesn't hide bad usages of 'wrap-program'" + "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used" + (let* ((phases + ;; Taken from the "straw-viewer" package + `(modify-phases %standard-phases + (add-after 'install 'wrap-program + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin-dir (string-append out "/bin/")) + (site-dir (string-append out "/lib/perl5/site_perl/")) + (lib-path (getenv "PERL5LIB"))) + (for-each (cut wrap-program <> + `("PERL5LIB" ":" prefix + (,lib-path ,site-dir))) + (find-files bin-dir))))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal "bogus phase specifications don't crash the linter" + "invalid phase clause" + (let* ((phases + `(modify-phases %standard-phases + (add-invalid))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + (test-equal "file patches: different file name -> warning" "file names of patches should start with the package name" (single-lint-warning-message -- cgit 1.4.1 From edb328ad83bf55e021018719d24f7c29adc43a96 Mon Sep 17 00:00:00 2001 From: Brice Waegeneire Date: Sat, 19 Jun 2021 21:59:48 +0200 Subject: lint: Check for leading whitespace in description. * guix/lint.scm (check-description-style): Check for leading whitespace. * tests/lint.scm: ("description: leading whitespace"): New test. --- guix/lint.scm | 11 +++++++++++ tests/lint.scm | 7 +++++++ 2 files changed, 18 insertions(+) (limited to 'tests') diff --git a/guix/lint.scm b/guix/lint.scm index 8f31de041d..ffd3f7007e 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2020 Timothy Sample ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Maxime Devos +;;; Copyright © 2021 Brice Waegeneire ;;; ;;; This file is part of GNU Guix. ;;; @@ -376,6 +377,15 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") infractions) #:field 'description))))) + (define (check-no-leading-whitespace description) + "Check that DESCRIPTION doesn't have trailing whitespace." + (if (string-prefix? " " description) + (list + (make-warning package + (G_ "description contains leading whitespace") + #:field 'description)) + '())) + (define (check-no-trailing-whitespace description) "Check that DESCRIPTION doesn't have trailing whitespace." (if (string-suffix? " " description) @@ -394,6 +404,7 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") ;; Use raw description for this because Texinfo rendering ;; automatically fixes end of sentence space. (check-end-of-sentence-space description) + (check-no-leading-whitespace description) (check-no-trailing-whitespace description) (match (check-texinfo-markup description) ((and warning (? lint-warning?)) (list warning)) diff --git a/tests/lint.scm b/tests/lint.scm index 82971db8f0..0f51b9ef79 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -163,6 +163,13 @@ (description "This is a 'quoted' thing.")))) (check-description-style pkg)))) +(test-equal "description: leading whitespace" + "description contains leading whitespace" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description " Whitespace.")))) + (check-description-style pkg)))) + (test-equal "description: trailing whitespace" "description contains trailing whitespace" (single-lint-warning-message -- cgit 1.4.1 From 3217a04b0352c2dd13323257b369604eeabfccc3 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 17 Jul 2021 22:38:38 -0400 Subject: tests/go: Remove unused variable. * tests/go.scm: Delete extraneous newline. (fixture-latest-for-go-check): Remove variable. --- tests/go.scm | 7 ------- 1 file changed, 7 deletions(-) (limited to 'tests') diff --git a/tests/go.scm b/tests/go.scm index b088ab50d2..2dfdc97eb5 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -57,7 +57,6 @@ require ( exclude D v1.2.3 ") - (define fixture-go-mod-complete "module M @@ -96,12 +95,6 @@ replace ( ") - - -(define fixture-latest-for-go-check - "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") - - (define fixtures-go-check-test (let ((version "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") -- cgit 1.4.1 From 793ba333c6039545684e8af7e384704e76bc0f2f Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Fri, 16 Jul 2021 21:01:28 -0700 Subject: import: go: Upgrade go.mod parser. Upgrade the go.mod parser to handle the full go.mod spec, and to gracefully handle unexpected/malformed syntax. Restructure parser usage, making the parse tree available for other uses. guix/import/go.scm (parse-go.mod): Parse using (ice-9 peg) instead of regex matching for more robustness. Return a list of directives. (go.mod-directives): New procedure. (go.mod-requirements): Likewise. (go-module->guix-package): Use it. (%go.mod-replace-directive-rx): Remove unused variable. tests/go.scm (testing-parse-mod): Adjust accordingly. (go.mod-requirements) (fixture-go-mod-unparseable) (fixture-go-mod-retract) (fixture-go-mod-strings): New variables. ("parse-go.mod: simple") ("parse-go.mod: comments and unparseable lines") ("parse-go.mod: retract") ("parse-go.mod: raw strings and quoted strings") ("parse-go.mod: complete"): New tests. Signed-off-by: Maxim Cournoyer --- guix/import/go.scm | 249 ++++++++++++++++++++++++++++------------------------- tests/go.scm | 133 +++++++++++++++++++++++++++- 2 files changed, 262 insertions(+), 120 deletions(-) (limited to 'tests') diff --git a/guix/import/go.scm b/guix/import/go.scm index 24d12acd97..a6e2af215f 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Ludovic Courtès ;;; Copyright © 2021 Xinglu Chen -;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2021 Sarah Morgensen ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +41,7 @@ #:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix build utils) (mkdir-p) #:use-module (ice-9 match) + #:use-module (ice-9 peg) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -244,129 +245,139 @@ and VERSION and return an input port." (go-path-escape version)))) (http-fetch* url))) -(define %go.mod-require-directive-rx - ;; A line in a require directive is composed of a module path and - ;; a version separated by whitespace and an optionnal '//' comment at - ;; the end. - (make-regexp - (string-append - "^[[:blank:]]*([^[:blank:]]+)[[:blank:]]+" ;the module path - "([^[:blank:]]+)" ;the version - "([[:blank:]]+//.*)?"))) ;an optional comment - -(define %go.mod-replace-directive-rx - ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline - ;; | ModulePath [ Version ] "=>" ModulePath Version newline . - (make-regexp - (string-append - "([^[:blank:]]+)" ;the module path - "([[:blank:]]+([^[:blank:]]+))?" ;optional version - "[[:blank:]]+=>[[:blank:]]+" - "([^[:blank:]]+)" ;the file or module path - "([[:blank:]]+([^[:blank:]]+))?"))) ;the version (if a module path) (define (parse-go.mod content) - "Parse the go.mod file CONTENT, returning a list of requirements." - ;; We parse only a subset of https://golang.org/ref/mod#go-mod-file-grammar - ;; which we think necessary for our use case. - (define (toplevel requirements replaced) - "This is the main parser. The results are accumulated in THE REQUIREMENTS -and REPLACED lists." - (let ((line (read-line))) - (cond - ((eof-object? line) - ;; parsing ended, give back the result - (values requirements replaced)) - ((string=? line "require (") - ;; a require block begins, delegate parsing to IN-REQUIRE - (in-require requirements replaced)) - ((string=? line "replace (") - ;; a replace block begins, delegate parsing to IN-REPLACE - (in-replace requirements replaced)) - ((string-prefix? "require " line) - ;; a require directive by itself - (let* ((stripped-line (string-drop line 8))) - (call-with-values - (lambda () - (require-directive requirements replaced stripped-line)) - toplevel))) - ((string-prefix? "replace " line) - ;; a replace directive by itself - (let* ((stripped-line (string-drop line 8))) - (call-with-values - (lambda () - (replace-directive requirements replaced stripped-line)) - toplevel))) - (#t - ;; unrecognised line, ignore silently - (toplevel requirements replaced))))) - - (define (in-require requirements replaced) - (let ((line (read-line))) - (cond - ((eof-object? line) - ;; this should never happen here but we ignore silently - (values requirements replaced)) - ((string=? line ")") - ;; end of block, coming back to toplevel - (toplevel requirements replaced)) - (#t - (call-with-values (lambda () - (require-directive requirements replaced line)) - in-require))))) - - (define (in-replace requirements replaced) - (let ((line (read-line))) - (cond - ((eof-object? line) - ;; this should never happen here but we ignore silently - (values requirements replaced)) - ((string=? line ")") - ;; end of block, coming back to toplevel - (toplevel requirements replaced)) - (#t - (call-with-values (lambda () - (replace-directive requirements replaced line)) - in-replace))))) - - (define (replace-directive requirements replaced line) - "Extract replaced modules and new requirements from the replace directive -in LINE and add them to the REQUIREMENTS and REPLACED lists." - (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line)) - (module-path (match:substring rx-match 1)) - (version (match:substring rx-match 3)) - (new-module-path (match:substring rx-match 4)) - (new-version (match:substring rx-match 6)) - (new-replaced (cons (list module-path version) replaced)) - (new-requirements - (if (string-match "^\\.?\\./" new-module-path) - requirements - (cons (list new-module-path new-version) requirements)))) - (values new-requirements new-replaced))) - - (define (require-directive requirements replaced line) - "Extract requirement from LINE and augment the REQUIREMENTS and REPLACED -lists." - (let* ((rx-match (regexp-exec %go.mod-require-directive-rx line)) - (module-path (match:substring rx-match 1)) - ;; Double-quoted strings were seen in the wild without escape - ;; sequences; trim the quotes to be on the safe side. - (module-path (string-trim-both module-path #\")) - (version (match:substring rx-match 2))) - (values (cons (list module-path version) requirements) replaced))) - - (with-input-from-string content - (lambda () - (receive (requirements replaced) - (toplevel '() '()) - ;; At last remove the replaced modules from the requirements list. - (remove (lambda (r) - (assoc (car r) replaced)) - requirements))))) + "Parse the go.mod file CONTENT, returning a list of directives, comments, +and unknown lines. Each sublist begins with a symbol (go, module, require, +replace, exclude, retract, comment, or unknown) and is followed by one or more +sublists. Each sublist begins with a symbol (module-path, version, file-path, +comment, or unknown) and is followed by the indicated data." + ;; https://golang.org/ref/mod#go-mod-file-grammar + (define-peg-pattern NL none "\n") + (define-peg-pattern WS none (or " " "\t" "\r")) + (define-peg-pattern => none (and (* WS) "=>")) + (define-peg-pattern punctuation none (or "," "=>" "[" "]" "(" ")")) + (define-peg-pattern comment all + (and (ignore "//") (* WS) (* (and (not-followed-by NL) peg-any)))) + (define-peg-pattern EOL body (and (* WS) (? comment) NL)) + (define-peg-pattern block-start none (and (* WS) "(" EOL)) + (define-peg-pattern block-end none (and (* WS) ")" EOL)) + (define-peg-pattern any-line body + (and (* WS) (* (and (not-followed-by NL) peg-any)) EOL)) + + ;; Strings and identifiers + (define-peg-pattern identifier body + (+ (and (not-followed-by (or NL WS punctuation)) peg-any))) + (define-peg-pattern string-raw body + (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`"))) + (define-peg-pattern string-quoted body + (and (ignore "\"") + (+ (or (and (ignore "\\") peg-any) + (and (not-followed-by "\"") peg-any))) + (ignore "\""))) + (define-peg-pattern string-or-ident body + (and (* WS) (or string-raw string-quoted identifier))) + + (define-peg-pattern version all string-or-ident) + (define-peg-pattern module-path all string-or-ident) + (define-peg-pattern file-path all string-or-ident) + + ;; Non-directive lines + (define-peg-pattern unknown all any-line) + (define-peg-pattern block-line body + (or EOL (and (not-followed-by block-end) unknown))) + + ;; GoDirective = "go" GoVersion newline . + (define-peg-pattern go all (and (ignore "go") version EOL)) + + ;; ModuleDirective = "module" ( ModulePath | "(" newline ModulePath newline ")" ) newline . + (define-peg-pattern module all + (and (ignore "module") (or (and block-start module-path EOL block-end) + (and module-path EOL)))) + + ;; The following directives may all be used solo or in a block + ;; RequireSpec = ModulePath Version newline . + (define-peg-pattern require all (and module-path version EOL)) + (define-peg-pattern require-top body + (and (ignore "require") + (or (and block-start (* (or require block-line)) block-end) require))) + + ;; ExcludeSpec = ModulePath Version newline . + (define-peg-pattern exclude all (and module-path version EOL)) + (define-peg-pattern exclude-top body + (and (ignore "exclude") + (or (and block-start (* (or exclude block-line)) block-end) exclude))) + + ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline + ;; | ModulePath [ Version ] "=>" ModulePath Version newline . + (define-peg-pattern original all (or (and module-path version) module-path)) + (define-peg-pattern with all (or (and module-path version) file-path)) + (define-peg-pattern replace all (and original => with EOL)) + (define-peg-pattern replace-top body + (and (ignore "replace") + (or (and block-start (* (or replace block-line)) block-end) replace))) + + ;; RetractSpec = ( Version | "[" Version "," Version "]" ) newline . + (define-peg-pattern range all + (and (* WS) (ignore "[") version + (* WS) (ignore ",") version (* WS) (ignore "]"))) + (define-peg-pattern retract all (and (or range version) EOL)) + (define-peg-pattern retract-top body + (and (ignore "retract") + (or (and block-start (* (or retract block-line)) block-end) retract))) + + (define-peg-pattern go-mod body + (* (and (* WS) (or go module require-top exclude-top replace-top + retract-top EOL unknown)))) + + (let ((tree (peg:tree (match-pattern go-mod content))) + (keywords '(go module require replace exclude retract comment unknown))) + (keyword-flatten keywords tree))) ;; Prevent inlining of this procedure, which is accessed by unit tests. (set! parse-go.mod parse-go.mod) +(define (go.mod-directives go.mod directive) + "Return the list of top-level directive bodies in GO.MOD matching the symbol +DIRECTIVE." + (filter-map (match-lambda + (((? (cut eq? <> directive) head) . rest) rest) + (_ #f)) + go.mod)) + +(define (go.mod-requirements go.mod) + "Compute and return the list of requirements specified by GO.MOD." + (define (replace directive requirements) + (define (maybe-replace module-path new-requirement) + ;; Do not allow version updates for indirect dependencies (see: + ;; https://golang.org/ref/mod#go-mod-file-replace). + (if (and (equal? module-path (first new-requirement)) + (not (assoc-ref requirements module-path))) + requirements + (cons new-requirement (alist-delete module-path requirements)))) + + (match directive + ((('original ('module-path module-path) . _) with . _) + (match with + (('with ('file-path _) . _) + (alist-delete module-path requirements)) + (('with ('module-path new-module-path) ('version new-version) . _) + (maybe-replace module-path + (list new-module-path new-version))))))) + + (define (require directive requirements) + (match directive + ((('module-path module-path) ('version version) . _) + (cons (list module-path version) requirements)))) + + (let* ((requires (go.mod-directives go.mod 'require)) + (replaces (go.mod-directives go.mod 'replace)) + (requirements (fold require '() requires))) + (fold replace requirements replaces))) + +;; Prevent inlining of this procedure, which is accessed by unit tests. +(set! go.mod-requirements go.mod-requirements) + (define-record-type (%make-vcs url-prefix root-regex type) vcs? @@ -592,7 +603,7 @@ When VERSION is unspecified, the latest version available is used." hint: use one of the following available versions ~a\n" version* available-versions)))) (content (fetch-go.mod goproxy module-path version*)) - (dependencies+versions (parse-go.mod content)) + (dependencies+versions (go.mod-requirements (parse-go.mod content))) (dependencies (if pin-versions? dependencies+versions (map car dependencies+versions))) diff --git a/tests/go.scm b/tests/go.scm index 2dfdc97eb5..6749f4585f 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 François Joulaud +;;; Copyright © 2021 Sarah Morgensen ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,9 @@ #:use-module (srfi srfi-64) #:use-module (web response)) +(define go.mod-requirements + (@@ (guix import go) go.mod-requirements)) + (define parse-go.mod (@@ (guix import go) parse-go.mod)) @@ -95,6 +99,41 @@ replace ( ") +(define fixture-go-mod-unparseable + "module my/thing +go 1.12 // avoid feature X +require other/thing v1.0.2 +// Security issue: CVE-XXXXX +exclude old/thing v1.2.3 +new-directive another/thing yet-another/thing +replace ( + bad/thing v1.4.5 => good/thing v1.4.5 + // Unparseable + bad/thing [v1.4.5, v1.9.7] => good/thing v2.0.0 +) +") + +(define fixture-go-mod-retract + "retract v0.9.1 + +retract ( + v1.9.2 + [v1.0.0, v1.7.9] +) +") + +(define fixture-go-mod-strings + "require `example.com/\"some-repo\"` v1.9.3 +require ( + `example.com/\"another.repo\"` v1.0.0 + \"example.com/special!repo\" v9.3.1 +) +replace \"example.com/\\\"some-repo\\\"\" => `launchpad.net/some-repo` v1.9.3 +replace ( + \"example.com/\\\"another.repo\\\"\" => launchpad.net/another-repo v1.0.0 +) +") + (define fixtures-go-check-test (let ((version "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") @@ -178,7 +217,7 @@ require github.com/kr/pretty v0.2.1 (string good/thing v2.0.0")) + (parse-go.mod fixture-go-mod-unparseable)) + +(test-equal "parse-go.mod: retract" + `((retract (version "v0.9.1")) + (retract (version "v1.9.2")) + (retract (range (version "v1.0.0") (version "v1.7.9")))) + (parse-go.mod fixture-go-mod-retract)) + +(test-equal "parse-go.mod: raw strings and quoted strings" + `((require (module-path "example.com/\"some-repo\"") (version "v1.9.3")) + (require (module-path "example.com/\"another.repo\"") (version "v1.0.0")) + (require (module-path "example.com/special!repo") (version "v9.3.1")) + (replace (original (module-path "example.com/\"some-repo\"")) + (with (module-path "launchpad.net/some-repo") (version "v1.9.3"))) + (replace (original (module-path "example.com/\"another.repo\"")) + (with (module-path "launchpad.net/another-repo") (version "v1.0.0")))) + (parse-go.mod fixture-go-mod-strings)) + +(test-equal "parse-go.mod: complete" + `((module (module-path "M")) + (go (version "1.13")) + (replace (original (module-path "github.com/myname/myproject/myapi")) + (with (file-path "./api"))) + (replace (original (module-path "github.com/mymname/myproject/thissdk")) + (with (file-path "../sdk"))) + (replace (original (module-path "launchpad.net/gocheck")) + (with (module-path "github.com/go-check/check") + (version "v0.0.0-20140225173054-eb6ee6f84d0a"))) + (require (module-path "github.com/user/project") + (version "v1.1.11")) + (require (module-path "github.com/user/project/sub/directory") + (version "v1.1.12")) + (require (module-path "bitbucket.org/user/project") + (version "v1.11.20")) + (require (module-path "bitbucket.org/user/project/sub/directory") + (version "v1.11.21")) + (require (module-path "launchpad.net/project") + (version "v1.1.13")) + (require (module-path "launchpad.net/project/series") + (version "v1.1.14")) + (require (module-path "launchpad.net/project/series/sub/directory") + (version "v1.1.15")) + (require (module-path "launchpad.net/~user/project/branch") + (version "v1.1.16")) + (require (module-path "launchpad.net/~user/project/branch/sub/directory") + (version "v1.1.17")) + (require (module-path "hub.jazz.net/git/user/project") + (version "v1.1.18")) + (require (module-path "hub.jazz.net/git/user/project/sub/directory") + (version "v1.1.19")) + (require (module-path "k8s.io/kubernetes/subproject") + (version "v1.1.101")) + (require (module-path "one.example.com/abitrary/repo") + (version "v1.1.111")) + (require (module-path "two.example.com/abitrary/repo") + (version "v0.0.2")) + (require (module-path "quoted.example.com/abitrary/repo") + (version "v0.0.2")) + (replace (original (module-path "two.example.com/abitrary/repo")) + (with (module-path "github.com/corp/arbitrary-repo") + (version "v0.0.2"))) + (replace (original (module-path "golang.org/x/sys")) + (with (module-path "golang.org/x/sys") + (version "v0.0.0-20190813064441-fde4db37ae7a")) + (comment "pinned to release-branch.go1.13")) + (replace (original (module-path "golang.org/x/tools")) + (with (module-path "golang.org/x/tools") + (version "v0.0.0-20190821162956-65e3620a7ae7")) + (comment "pinned to release-branch.go1.13"))) + (parse-go.mod fixture-go-mod-complete)) + ;;; End-to-end tests for (guix import go) (define (mock-http-fetch testcase) (lambda (url . rest) -- cgit 1.4.1 From aeded14b8342c1e72afd014a1bc121770f8c3a1c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 22:47:51 -0400 Subject: pack: Allow embedding custom control files in deb packs. * guix/scripts/pack.scm (self-contained-tarball/builder) [extra-options]: New argument. (self-contained-tarball, squashfs-image, docker-image) (debian-archive): Likewise. Remove two TODO comments. Document EXTRA-OPTIONS. Use the custom control files when provided. (%deb-format-options): New variable. (show-deb-format-options, show-deb-format-options/detailed): New procedures. (%options): Register new options. (show-help): Augment with new usage. (guix-pack): Validate and propagate new argument values. * doc/guix.texi (Invoking guix pack)[deb]: Document how to list advanced options. Add an example. * tests/pack.scm (deb archive...): Provide extra-options to the debian-archive procedure, and validate that the provided files are embedded in the pack. --- doc/guix.texi | 8 ++++ guix/scripts/pack.scm | 121 ++++++++++++++++++++++++++++++++++++++++++-------- tests/pack.scm | 27 ++++++++--- 3 files changed, 133 insertions(+), 23 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index cca46218f2..b3c16e6507 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6047,6 +6047,14 @@ such file or directory'' message. 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. +Advanced options can be revealed via the @option{--help-deb-format} +option. They allow embedding control files for more fine-grained +control, such as activating specific triggers or providing a maintainer +configure script to run arbitrary setup code upon installation. + +@example +guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello +@end example @quotation Note Because archives produced with @command{guix pack} contain a collection diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6d8b70d1c7..6a8d49e042 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -205,7 +205,8 @@ its source property." (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return the G-Expression of the builder used for self-contained-tarball." (define database (and localstatedir? @@ -324,7 +325,8 @@ its source property." (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -389,7 +391,8 @@ to the search paths of PROFILE." entry-point localstatedir? (symlinks '()) - (archiver squashfs-tools)) + (archiver squashfs-tools) + (extra-options '())) "Return a squashfs image containing a store initialized with the closure of PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount points for virtual file systems (like procfs), and optional symlinks. @@ -567,7 +570,8 @@ added to the pack." entry-point localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -654,8 +658,6 @@ the image." ;;; 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") @@ -664,7 +666,8 @@ the image." (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "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 @@ -672,7 +675,8 @@ 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." +added to the pack. EXTRA-OPTIONS may contain the CONFIG-FILE, POSTINST-FILE +or TRIGGERS-FILE keyword arguments." ;; 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). @@ -714,21 +718,23 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (guix build utils) (guix profiles) (ice-9 match) + ((oop goops) #:select (get-keyword)) (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 #\-))))) + (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") + ("i586" "i386") ("i686" "i386") ("x86_64" "amd64") ("aarch64" "arm64") @@ -773,21 +779,40 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (copy-file #+data-tarball data-tarball-file-name) + ;; Generate the control archive. + (define control-file + (get-keyword #:control-file '#$extra-options)) + + (define postinst-file + (get-keyword #:postinst-file '#$extra-options)) + + (define triggers-file + (get-keyword #:triggers-file '#$extra-options)) + (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 "\ + (if control-file + (copy-file control-file "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))) +~%" package-name package-version architecture)))) + + (when postinst-file + (copy-file postinst-file "postinst") + (chmod "postinst" #o755)) + + (when triggers-file + (copy-file triggers-file "triggers")) (define tar (string-append #+archiver "/bin/tar")) @@ -796,7 +821,9 @@ Architecture: ~a #:tar tar #:compressor '#+(and=> compressor compressor-command)) "-cvf" ,control-tarball-file-name - "control")) + "control" + ,@(if postinst-file '("postinst") '()) + ,@(if triggers-file '("triggers") '()))) ;; Create the .deb archive using GNU ar. (invoke (string-append #+binutils "/bin/ar") "-rv" #$output @@ -1157,6 +1184,34 @@ last resort for relocation." deb Debian archive installable via dpkg/apt")) (newline)) +(define %deb-format-options + (let ((required-option (lambda (symbol) + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file)))) + +(define (show-deb-format-options) + (display (G_ " + --help-deb-format list options specific to the deb format"))) + +(define (show-deb-format-options/detailed) + (display (G_ " + --control-file=FILE + Embed the provided control FILE")) + (display (G_ " + --postinst-file=FILE + Embed the provided postinst script")) + (display (G_ " + --triggers-file=FILE + Embed the provided triggers FILE")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1250,7 +1305,12 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) - (append %transformation-options + (option '("help-deb-format") #f #f + (lambda args + (show-deb-format-options/detailed))) + + (append %deb-format-options + %transformation-options %standard-build-options))) (define (show-help) @@ -1260,6 +1320,8 @@ Create a bundle of PACKAGE.\n")) (newline) (show-transformation-options-help) (newline) + (show-deb-format-options) + (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " @@ -1369,6 +1431,18 @@ Create a bundle of PACKAGE.\n")) (else (packages->manifest packages)))))) + (define (process-file-arg opts name) + ;; Validate that the file exists and return it as a object, + ;; else #f. + (let ((value (assoc-ref opts name))) + (match value + ((and (? string?) (not (? file-exists?))) + (leave (G_ "file provided with option ~a does not exist: ~a~%") + (string-append "--" (symbol->string name)) value)) + ((? string?) + (local-file value)) + (#f #f)))) + (with-error-handling (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -1401,6 +1475,15 @@ Create a bundle of PACKAGE.\n")) manifest) manifest))) (pack-format (assoc-ref opts 'format)) + (extra-options (match pack-format + ('deb + (list #:control-file + (process-file-arg opts 'control-file) + #:postinst-file + (process-file-arg opts 'postinst-file) + #:triggers-file + (process-file-arg opts 'triggers-file))) + (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1465,7 +1548,9 @@ to your package list."))) #:profile-name profile-name #:archiver - archiver))) + archiver + #:extra-options + extra-options))) (mbegin %store-monad (mwhen derivation? (return (format #t "~a~%" diff --git a/tests/pack.scm b/tests/pack.scm index 9473d4f384..e9b4c36e0e 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -277,17 +277,25 @@ (built-derivations (list check)))) (unless store (test-skip 1)) - (test-assertm "deb archive with symlinks" store + (test-assertm "deb archive with symlinks and control files" 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)) + (deb (debian-archive + "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap + #:extra-options + (list #:triggers-file + (plain-file "triggers" + "activate-noawait /usr/share/icons/hicolor\n") + #:postinst-file + (plain-file "postinst" + "echo running configure script\n")))) (check (gexp->derivation "check-deb-pack" (with-imported-modules '((guix build utils)) @@ -344,6 +352,15 @@ (unless (null? hard-links) (error "hard links found in data.tar.gz" hard-links)) + ;; Verify the presence of the control files. + (invoke "tar" "-xf" "control.tar.gz") + (assert (file-exists? "control")) + (assert (and (file-exists? "postinst") + (= #o111 ;script is executable + (logand #o111 (stat:perms + (stat "postinst")))))) + (assert (file-exists? "triggers")) + (mkdir #$output)))))) (built-derivations (list check))))) -- cgit 1.4.1 From 11f0698243da27be93b16cec574fbf262279779a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 6 Jul 2021 12:27:36 -0400 Subject: pack: Streamline how files are included in tarballs. Thanks to Guillem Jover on the OFTC's #debian-dpkg channel for helping with troubleshooting. Letting GNU Tar recursively walk the complete files hierarchy side-steps the risks associated with providing a list of file names: 1. Duplicated files in the archive (recorded as hard links by GNU Tar) 2. Missing parent directories. The above would cause dpkg to malfunction, for example by aborting early and skipping triggers when there were missing parent directories. * guix/scripts/pack.scm (self-contained-tarball/builder): Do not call POPULATE-SINGLE-PROFILE-DIRECTORY, which creates extraneous files such as /root. Instead, call POPULATE-STORE and INSTALL-DATABASE-AND-GC-ROOTS individually to more precisely generate the file system. Replace the list of files by the current directory, "." and streamline the way options are passed. * gnu/system/file-systems.scm (reduce-directories): Remove procedure. * tests/file-systems.scm ("reduce-directories"): Remove test. --- gnu/system/file-systems.scm | 22 -------------------- guix/scripts/pack.scm | 49 +++++++++++++++------------------------------ tests/file-systems.scm | 7 +------ 3 files changed, 17 insertions(+), 61 deletions(-) (limited to 'tests') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 4a3c1fe008..b9eda80958 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,7 +55,6 @@ file-system-dependencies file-system-location - reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -266,27 +265,6 @@ For example: (define (file-name-depth file-name) (length (string-tokenize file-name %not-slash))) -(define (reduce-directories file-names) - "Eliminate entries in FILE-NAMES that are children of other entries in -FILE-NAMES. This is for example useful when passing a list of files to GNU -tar, which would otherwise descend into each directory passed and archive the -duplicate files as hard links, which can be undesirable." - (let* ((file-names/sorted - ;; Ascending sort by file hierarchy depth, then by file name length. - (stable-sort (delete-duplicates file-names) - (lambda (f1 f2) - (let ((depth1 (file-name-depth f1)) - (depth2 (file-name-depth f2))) - (if (= depth1 depth2) - (string< f1 f2) - (< depth1 depth2))))))) - (reverse (fold (lambda (file-name results) - (if (find (cut file-prefix? <> file-name) results) - results ;parent found -- skipping - (cons file-name results))) - '() - file-names/sorted)))) - (define* (file-system-device->string device #:key uuid-type) "Return the string representations of the DEVICE field of a record. When the device is a UUID, its representation is chosen depending on diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78201d6f5f..9e1f270dfb 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -231,17 +231,17 @@ its source property." (with-imported-modules (source-module-closure `((guix build pack) + (guix build store-copy) (guix build utils) (guix build union) - (gnu build install) - (gnu system file-systems)) + (gnu build install)) #:select? import-module?) #~(begin (use-modules (guix build pack) + (guix build store-copy) (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) - ((gnu system file-systems) #:select (reduce-directories)) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -279,11 +279,11 @@ its source property." ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs ;; with hard links: ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:profile-name #$profile-name - #:closure "profile" - #:database #+database) + (populate-store (list "profile") %root #:deduplicate? #f) + + (when #+localstatedir? + (install-database-and-gc-roots %root #+database #$profile + #:profile-name #$profile-name)) ;; Create SYMLINKS. (for-each (cut evaluate-populate-directive <> %root) @@ -291,31 +291,14 @@ its source property." ;; Create the tarball. (with-directory-excursion %root - (apply invoke tar - `(,@(tar-base-options - #:tar tar - #:compressor '#+(and=> compressor compressor-command)) - "-cvf" ,#$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - ,#$@(if localstatedir? - '("./var/guix") - '()) - - ,(string-append "." (%store-directory)) - - ,@(reduce-directories - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))) + ;; GNU Tar recurses directories by default. Simply add the whole + ;; current directory, which contains all the generated files so far. + ;; This avoids creating duplicate files in the archives that would + ;; be stored as hard links by GNU Tar. + (apply invoke tar "-cvf" #$output "." + (tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command))))))) (define* (self-contained-tarball name profile #:key target diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 80acb6d5b9..7f7c373884 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès -;;; Copyright © 2020, 2021 Maxim Cournoyer +;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,11 +50,6 @@ (device "/foo") (flags '(bind-mount read-only))))))))) -(test-equal "reduce-directories" - '("./opt/gnu/" "./opt/gnuism" "a/b/c") - (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin" - "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c"))) - (test-assert "does not pull (guix config)" ;; This module is meant both for the host side and "build side", so make ;; sure it doesn't pull in (guix config), which depends on the user's -- cgit 1.4.1