diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/download.scm | 36 | ||||
| -rw-r--r-- | guix/build/node-build-system.scm | 9 | ||||
| -rw-r--r-- | guix/build/pack.scm | 54 | ||||
| -rw-r--r-- | guix/build/qt-build-system.scm | 107 | ||||
| -rw-r--r-- | guix/build/qt-utils.scm | 151 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 4 |
6 files changed, 220 insertions, 141 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index b14db42352..54627eefa2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -281,21 +281,27 @@ host name without trailing dot." ;;(set-log-level! 10) ;;(set-log-procedure! log) - (catch 'gnutls-error - (lambda () - (handshake session)) - (lambda (key err proc . rest) - (cond ((eq? err error/warning-alert-received) - ;; Like Wget, do no stop upon non-fatal alerts such as - ;; 'alert-description/unrecognized-name'. - (format (current-error-port) - "warning: TLS warning alert received: ~a~%" - (alert-description->string (alert-get session))) - (handshake session)) - (else - ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't - ;; provide a binding for this. - (apply throw key err proc rest))))) + (let loop ((retries 5)) + (catch 'gnutls-error + (lambda () + (handshake session)) + (lambda (key err proc . rest) + (cond ((eq? err error/warning-alert-received) + ;; Like Wget, do no stop upon non-fatal alerts such as + ;; 'alert-description/unrecognized-name'. + (format (current-error-port) + "warning: TLS warning alert received: ~a~%" + (alert-description->string (alert-get session))) + (handshake session)) + (else + (if (or (fatal-error? err) (zero? retries)) + (apply throw key err proc rest) + (begin + ;; We got 'error/again' or similar; try again. + (format (current-error-port) + "warning: TLS non-fatal error: ~a~%" + (error->string err)) + (loop (- retries 1))))))))) ;; Verify the server's certificate if needed. (when verify-certificate? diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index a55cab237c..70a367618e 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -120,7 +120,14 @@ #t) (define* (repack #:key inputs #:allow-other-keys) - (invoke "tar" "-czf" "../package.tgz" ".") + (invoke "tar" + ;; Add options suggested by https://reproducible-builds.org/docs/archives/ + "--sort=name" + (string-append "--mtime=@" (getenv "SOURCE_DATE_EPOCH")) + "--owner=0" + "--group=0" + "--numeric-owner" + "-czf" "../package.tgz" ".") #t) (define* (install #:key outputs inputs #:allow-other-keys) diff --git a/guix/build/pack.scm b/guix/build/pack.scm new file mode 100644 index 0000000000..3b73d1b227 --- /dev/null +++ b/guix/build/pack.scm @@ -0,0 +1,54 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build pack) + #:use-module (guix build utils) + #:export (tar-base-options)) + +(define* (tar-base-options #:key tar compressor) + "Return the base GNU tar options required to produce deterministic archives +deterministically. When TAR, a GNU tar command file name, is provided, the +`--sort' option is used only if supported. When COMPRESSOR, a command such as +'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via +the `-I' option." + (define (tar-supports-sort? tar) + (with-error-to-port (%make-void-port "w") + (lambda () + (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))))) + + `(,@(if compressor + (list "-I" (string-join compressor)) + '()) + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is older + ;; and doesn't support it. + ,@(if (and=> tar tar-supports-sort?) + '("--sort=name") + '()) + ;; Use GNU format so there's no file name length limitation. + "--format=gnu" + "--mtime=@1" + "--owner=root:0" + "--group=root:0" + ;; The 'nlink' of the store item files leads tar to store hard links + ;; instead of actual copies. However, the 'nlink' count depends on + ;; deduplication in the store; it's an "implicit input" to the build + ;; process. Use '--hard-dereference' to eliminate it. + "--hard-dereference" + "--check-links")) diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index ec7ceb38bd..c63bd5ed21 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -1,8 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> -;;; Copyright © 2014, 2015, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> -;;; Copyright © 2019, 2020 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2019, 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. @@ -23,6 +23,7 @@ (define-module (guix build qt-build-system) #:use-module ((guix build cmake-build-system) #:prefix cmake:) #:use-module (guix build utils) + #:use-module (guix build qt-utils) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 ftw) @@ -48,110 +49,10 @@ (setenv "CTEST_OUTPUT_ON_FAILURE" "1") #t) -(define (variables-for-wrapping base-directories) - - (define (collect-sub-dirs base-directories file-type subdirectory - selectors) - ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset - ;; that exists and has at least one of the SELECTORS sub-directories, - ;; unless SELECTORS is the empty list. FILE-TYPE should by 'directory or - ;; 'regular file. For the later, it allows searching for plain files - ;; rather than directories. - (define exists? (match file-type - ('directory directory-exists?) - ('regular file-exists?))) - - (filter-map (lambda (dir) - (let ((directory (string-append dir subdirectory))) - (and (exists? directory) - (or (null? selectors) - (any (lambda (selector) - (exists? - (string-append directory selector))) - selectors)) - directory))) - base-directories)) - - (filter-map - (match-lambda - ((variable file-type directory selectors ...) - (match (collect-sub-dirs base-directories file-type directory - selectors) - (() - #f) - (directories - `(,variable = ,directories))))) - - ;; These shall match the search-path-specification for Qt and KDE - ;; libraries. - (list '("XDG_DATA_DIRS" directory "/share" - - ;; These are "selectors": consider /share if and only if at least - ;; one of these sub-directories exist. This avoids adding - ;; irrelevant packages to XDG_DATA_DIRS just because they have a - ;; /share sub-directory. - "/glib-2.0/schemas" "/sounds" "/themes" - "/cursors" "/wallpapers" "/icons" "/mime") - '("XDG_CONFIG_DIRS" directory "/etc/xdg") - '("QT_PLUGIN_PATH" directory "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" directory "/lib/qt5/qml") - '("QTWEBENGINEPROCESS_PATH" regular - "/lib/qt5/libexec/QtWebEngineProcess")))) - -(define* (wrap-all-programs #:key inputs outputs - (qt-wrap-excluded-outputs '()) - #:allow-other-keys) - "Implement phase \"qt-wrap\": look for GSettings schemas and -gtk+-v.0 libraries and create wrappers with suitably set environment variables -if found. - -Wrapping is not applied to outputs whose name is listed in -QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not -to contain any Qt binaries, and where wrapping would gratuitously -add a dependency of that output on Qt." - (define (find-files-to-wrap directory) - (append-map - (lambda (dir) - (if (directory-exists? dir) - (find-files dir (lambda (file stat) - (not (wrapped-program? file)))) - '())) - (list (string-append directory "/bin") - (string-append directory "/sbin") - (string-append directory "/libexec") - (string-append directory "/lib/libexec")))) - - (define input-directories - ;; FIXME: Filter out unwanted inputs, e.g. cmake - (match inputs - (((_ . dir) ...) - dir))) - - ;; Do not require bash to be present in the package inputs - ;; even when there is nothing to wrap. - ;; Also, calculate (sh) only once to prevent some I/O. - (define %sh (delay (search-input-file inputs "bin/bash"))) - (define (sh) (force %sh)) - - (define handle-output - (match-lambda - ((output . directory) - (unless (member output qt-wrap-excluded-outputs) - (let ((bin-list (find-files-to-wrap directory)) - (vars-to-wrap (variables-for-wrapping - (append (list directory) - input-directories)))) - (when (not (null? vars-to-wrap)) - (for-each (cut apply wrap-program <> #:sh (sh) vars-to-wrap) - bin-list))))))) - - (for-each handle-output outputs) - #t) - (define %standard-phases (modify-phases cmake:%standard-phases (add-before 'check 'check-setup check-setup) - (add-after 'install 'qt-wrap wrap-all-programs))) + (add-after 'install 'qt-wrap wrap-all-qt-programs))) (define* (qt-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index d2486ee86c..c2b80cab7d 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -1,5 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2019, 2020, 2021 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,23 +22,130 @@ (define-module (guix build qt-utils) #:use-module (guix build utils) - #:export (wrap-qt-program)) - -(define (wrap-qt-program out program) - (define (suffix env-var path) - (let ((env-val (getenv env-var))) - (if env-val (string-append env-val ":" path) path))) - - (let ((qml-path (suffix "QML2_IMPORT_PATH" - (string-append out "/lib/qt5/qml"))) - (plugin-path (suffix "QT_PLUGIN_PATH" - (string-append out "/lib/qt5/plugins"))) - (xdg-data-path (suffix "XDG_DATA_DIRS" - (string-append out "/share"))) - (xdg-config-path (suffix "XDG_CONFIG_DIRS" - (string-append out "/etc/xdg")))) - (wrap-program (string-append out "/bin/" program) - `("QML2_IMPORT_PATH" = (,qml-path)) - `("QT_PLUGIN_PATH" = (,plugin-path)) - `("XDG_DATA_DIRS" = (,xdg-data-path)) - `("XDG_CONFIG_DIRS" = (,xdg-config-path))))) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (wrap-qt-program + wrap-all-qt-programs + %qt-wrap-excluded-inputs)) + +(define %qt-wrap-excluded-inputs + '(list "cmake" "extra-cmake-modules" "qttools")) + +;; NOTE: Apart from standard subdirectories of /share, Qt also provides +;; facilities for per-application data directories, such as +;; /share/quassel. Thus, we include the output directory even if it doesn't +;; contain any of the standard subdirectories. +(define (variables-for-wrapping base-directories output-directory) + + (define (collect-sub-dirs base-directories file-type subdirectory selectors) + ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset + ;; that exists and has at least one of the SELECTORS sub-directories, + ;; unless SELECTORS is the empty list. FILE-TYPE should by 'directory or + ;; 'regular file. For the later, it allows searching for plain files + ;; rather than directories. + (define exists? (match file-type + ('directory directory-exists?) + ('regular file-exists?))) + + (filter-map (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (and (exists? directory) + (or (null? selectors) + (any (lambda (selector) + (exists? + (string-append directory selector))) + selectors)) + directory))) + base-directories)) + + (filter-map + (match-lambda + ((variable type file-type directory selectors ...) + (match (collect-sub-dirs base-directories file-type directory selectors) + (() + #f) + (directories + `(,variable ,type ,directories))))) + ;; These shall match the search-path-specification for Qt and KDE + ;; libraries. + (list + ;; The XDG environment variables are defined with the 'suffix type, which + ;; allows the users to override or extend their value, so that custom icon + ;; themes can be honored, for example. + '("XDG_DATA_DIRS" suffix directory "/share" + ;; These are "selectors": consider /share if and only if at least + ;; one of these sub-directories exist. This avoids adding + ;; irrelevant packages to XDG_DATA_DIRS just because they have a + ;; /share sub-directory. + "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas" + "/mime" "/sounds" "/themes" "/wallpapers") + '("XDG_CONFIG_DIRS" suffix directory "/etc/xdg") + ;; The following variables can be extended by the user, but not + ;; overridden, to ensure proper operation. + '("QT_PLUGIN_PATH" prefix directory "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" prefix directory "/lib/qt5/qml") + ;; QTWEBENGINEPROCESS_PATH accepts a single value, which makes 'exact the + ;; most suitable environment variable type for it. + '("QTWEBENGINEPROCESS_PATH" = regular + "/lib/qt5/libexec/QtWebEngineProcess")))) + +(define* (wrap-qt-program* program #:key inputs output-dir + qt-wrap-excluded-inputs) + + (define input-directories + (filter-map + (match-lambda + ((label . directory) + (and (not (member label qt-wrap-excluded-inputs)) + directory))) + inputs)) + + (let ((vars-to-wrap (variables-for-wrapping + (cons output-dir input-directories) + output-dir))) + (when (not (null? vars-to-wrap)) + (apply wrap-program program vars-to-wrap)))) + +(define* (wrap-qt-program program-name #:key inputs output + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) + "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" +directory) with suitably set environment variables. + +This is like qt-build-systems's phase \"qt-wrap\", but only the named program +is wrapped." + (wrap-qt-program* (string-append output "/bin/" program-name) + #:output-dir output #:inputs inputs + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs)) + +(define* (wrap-all-qt-programs #:key inputs outputs + (qt-wrap-excluded-outputs '()) + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) + #:allow-other-keys) + "Implement qt-build-systems's phase \"qt-wrap\": look for executables in +\"bin\", \"sbin\" and \"libexec\" of all outputs and create wrappers with +suitably set environment variables if found. + +Wrapping is not applied to outputs whose name is listed in +QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not +to contain any Qt binaries, and where wrapping would gratuitously +add a dependency of that output on Qt." + (define (find-files-to-wrap output-dir) + (append-map + (lambda (dir) + (if (directory-exists? dir) (find-files dir ".*") (list))) + (list (string-append output-dir "/bin") + (string-append output-dir "/sbin") + (string-append output-dir "/libexec") + (string-append output-dir "/lib/libexec")))) + + (define handle-output + (match-lambda + ((output . output-dir) + (unless (member output qt-wrap-excluded-outputs) + (for-each (cut wrap-qt-program* <> + #:output-dir output-dir #:inputs inputs + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs) + (find-files-to-wrap output-dir)))))) + + (for-each handle-output outputs)) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 8886fc0fb9..ac1b0c2eea 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -2236,8 +2236,8 @@ correspond to a terminal, return the value returned by FALL-BACK." ;; would return EINVAL instead in some cases: ;; <https://bugs.ruby-lang.org/issues/10494>. ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for - ;; that ioctl, and bcachefs returns EPERM. - (if (memv errno (list ENOTTY EINVAL ENOSYS EPERM)) + ;; that ioctl. + (if (memv errno (list ENOTTY EINVAL ENOSYS)) (fall-back) (apply throw args)))))) |