summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/qt.scm6
-rw-r--r--guix/build/download.scm36
-rw-r--r--guix/build/node-build-system.scm9
-rw-r--r--guix/build/pack.scm54
-rw-r--r--guix/build/qt-build-system.scm107
-rw-r--r--guix/build/qt-utils.scm151
-rw-r--r--guix/build/syscalls.scm4
-rw-r--r--guix/ci.scm129
-rw-r--r--guix/cpio.scm16
-rw-r--r--guix/docker.scm48
-rw-r--r--guix/gexp.scm20
-rw-r--r--guix/import/cabal.scm27
-rw-r--r--guix/import/go.scm329
-rw-r--r--guix/import/opam.scm2
-rw-r--r--guix/licenses.scm6
-rw-r--r--guix/lint.scm274
-rw-r--r--guix/profiles.scm2
-rw-r--r--guix/scripts/deploy.scm15
-rw-r--r--guix/scripts/pack.scm558
-rw-r--r--guix/scripts/package.scm37
-rw-r--r--guix/scripts/pull.scm20
-rwxr-xr-xguix/scripts/substitute.scm4
-rw-r--r--guix/scripts/system/reconfigure.scm9
-rw-r--r--guix/scripts/weather.scm17
-rw-r--r--guix/self.scm5
-rw-r--r--guix/status.scm3
-rw-r--r--guix/substitutes.scm13
-rw-r--r--guix/ui.scm91
-rw-r--r--guix/utils.scm33
29 files changed, 1368 insertions, 657 deletions
diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm
index ccee89d5ef..003a065aa6 100644
--- a/guix/build-system/qt.scm
+++ b/guix/build-system/qt.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +25,8 @@
#:use-module (guix utils)
#:use-module (guix gexp)
#:use-module (guix monads)
+ #:use-module ((guix build qt-utils)
+ #:select (%qt-wrap-excluded-inputs))
#:use-module (guix search-paths)
#:use-module (guix build-system)
#:use-module (guix build-system cmake)
@@ -54,6 +57,7 @@
(define %qt-build-system-modules
;; Build-side modules imported and used by default.
`((guix build qt-build-system)
+ (guix build qt-utils)
,@%cmake-build-system-modules))
(define (default-cmake)
@@ -125,6 +129,7 @@
"bin" "sbin"))
(phases '%standard-phases)
(qt-wrap-excluded-outputs ''())
+ (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)
(system (%current-system))
(imported-modules %qt-build-system-modules)
(modules '((guix build qt-build-system)
@@ -146,6 +151,7 @@ provides a 'CMakeLists.txt' file as its build system."
(sexp->gexp phases)
phases)
#:qt-wrap-excluded-outputs #$qt-wrap-excluded-outputs
+ #:qt-wrap-excluded-inputs #$qt-wrap-excluded-inputs
#:configure-flags #$configure-flags
#:make-flags #$make-flags
#:out-of-source? #$out-of-source?
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))))))
diff --git a/guix/ci.scm b/guix/ci.scm
index 0af04ff97d..6a3af8b42c 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -20,9 +20,12 @@
(define-module (guix ci)
#:use-module (guix http-client)
#:use-module (guix utils)
+ #:use-module ((guix build download)
+ #:select (resolve-uri-reference))
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
+ #:use-module (web uri)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
#:autoload (guix channels) (channel)
@@ -51,10 +54,18 @@
evaluation-complete?
evaluation-checkouts
+ job?
+ job-build-id
+ job-status
+ job-name
+
%query-limit
queued-builds
latest-builds
evaluation
+ evaluation-jobs
+ build
+ job-build
latest-evaluations
evaluations-for-commit
@@ -75,13 +86,31 @@
(file-size build-product-file-size) ;integer
(path build-product-path)) ;string
+(define-syntax-rule (define-enumeration-mapping proc
+ (names integers) ...)
+ (define (proc value)
+ (match value
+ (integers 'names) ...)))
+
+(define-enumeration-mapping integer->build-status
+ ;; Copied from 'build-status' in Cuirass.
+ (submitted -3)
+ (scheduled -2)
+ (started -1)
+ (succeeded 0)
+ (failed 1)
+ (failed-dependency 2)
+ (failed-other 3)
+ (canceled 4))
+
(define-json-mapping <build> make-build build?
json->build
(id build-id "id") ;integer
(derivation build-derivation) ;string | #f
(evaluation build-evaluation) ;integer
(system build-system) ;string
- (status build-status "buildstatus" ) ;integer
+ (status build-status "buildstatus" ;symbol
+ integer->build-status)
(timestamp build-timestamp) ;integer
(products build-products "buildproducts" ;<build-product>*
(lambda (products)
@@ -91,6 +120,13 @@
(vector->list products)
'())))))
+(define-json-mapping <job> make-job job?
+ json->job
+ (build-id job-build-id "build") ;integer
+ (status job-status "status" ;symbol
+ integer->build-status)
+ (name job-name)) ;string
+
(define-json-mapping <checkout> make-checkout checkout?
json->checkout
(commit checkout-commit) ;string (SHA1)
@@ -113,16 +149,44 @@
;; Max number of builds requested in queries.
1000)
+(define* (api-url base-url path #:rest query)
+ "Build a proper API url, taking into account BASE-URL's trailing slashes.
+QUERY takes any number of '(\"name\" value) 2-element lists, with VALUE being
+either a string or a number (which will be converted to a string). If VALUE
+is #f, the respective element will not be added to the query parameters.
+Other types of VALUE will raise an error since this low-level function is
+api-agnostic."
+
+ (define (build-query-string query)
+ (let lp ((query (or (reverse query) '())) (acc '()))
+ (match query
+ (() (string-concatenate acc))
+ (((_ #f) . rest) (lp rest acc))
+ (((name val) . rest)
+ (lp rest (cons*
+ name "="
+ (if (string? val) (uri-encode val) (number->string val))
+ (if (null? acc) "" "&")
+ acc))))))
+
+ (let* ((query-string (build-query-string query))
+ (base (string->uri base-url))
+ (ref (build-relative-ref #:path path #:query query-string)))
+ (resolve-uri-reference ref base)))
+
(define (json-fetch url)
(let* ((port (http-fetch url))
(json (json->scm port)))
(close-port port)
json))
+(define* (json-api-fetch base-url path #:rest query)
+ (json-fetch (apply api-url base-url path query)))
+
(define* (queued-builds url #:optional (limit %query-limit))
"Return the list of queued derivations on URL."
- (let ((queue (json-fetch (string-append url "/api/queue?nr="
- (number->string limit)))))
+ (let ((queue
+ (json-api-fetch url "/api/queue" `("nr" ,limit))))
(map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit)
@@ -130,28 +194,21 @@
"Return the latest builds performed by the CI server at URL. If EVALUATION
is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system
string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
- (define* (option name value #:optional (->string identity))
- (if value
- (string-append "&" name "=" (->string value))
- ""))
-
- (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
- (number->string limit)
- (option "evaluation" evaluation
- number->string)
- (option "system" system)
- (option "job" job)
- (option "status" status
- number->string)))))
+ (let ((latest (json-api-fetch
+ url "/api/latestbuilds"
+ `("nr" ,limit)
+ `("evaluation" ,evaluation)
+ `("system" ,system)
+ `("job" ,job)
+ `("status" ,status))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
(map json->build (vector->list latest))))
(define (evaluation url evaluation)
"Return the given EVALUATION performed by the CI server at URL."
- (let ((evaluation (json-fetch
- (string-append url "/api/evaluation?id="
- (number->string evaluation)))))
+ (let ((evaluation
+ (json-api-fetch url "/api/evaluation" `("id" ,evaluation))))
(json->evaluation evaluation)))
(define* (latest-evaluations url
@@ -159,16 +216,10 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
#:key spec)
"Return the latest evaluations performed by the CI server at URL. If SPEC
is passed, only consider the evaluations for the given SPEC specification."
- (let ((spec (if spec
- (format #f "&spec=~a" spec)
- "")))
- (map json->evaluation
- (vector->list
- (json->scm
- (http-fetch
- (string-append url "/api/evaluations?nr="
- (number->string limit)
- spec)))))))
+ (map json->evaluation
+ (vector->list
+ (json-api-fetch
+ url "/api/evaluations" `("nr" ,limit) `("spec" ,spec)))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
"Return the evaluations among the latest LIMIT evaluations that have COMMIT
@@ -179,6 +230,26 @@ as one of their inputs."
(evaluation-checkouts evaluation)))
(latest-evaluations url limit)))
+(define (evaluation-jobs url evaluation-id)
+ "Return the list of jobs of evaluation EVALUATION-ID."
+ (map json->job
+ (vector->list
+ (json-api-fetch url "/api/jobs" `("evaluation" ,evaluation-id)))))
+
+(define (build url id)
+ "Look up build ID at URL and return it. Raise &http-get-error if it is not
+found (404)."
+ (json->build
+ (http-fetch (api-url url (string-append "/build/" ;note: no "/api" here
+ (number->string id))))))
+
+(define (job-build url job)
+ "Return the build associated with JOB."
+ (build url (job-build-id job)))
+
+;; TODO: job history:
+;; https://ci.guix.gnu.org/api/jobs/history?spec=master&names=coreutils.x86_64-linux&nr=10
+
(define (find-latest-commit-with-substitutes url)
"Return the latest commit with available substitutes for the Guix package
definitions at URL. Return false if no commit were found."
diff --git a/guix/cpio.scm b/guix/cpio.scm
index c9932f5bf9..8038a11f3c 100644
--- a/guix/cpio.scm
+++ b/guix/cpio.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -153,15 +154,20 @@ denotes, similar to 'stat:type'."
(else
(error "unsupported file type" mode)))))
-(define (device-number major minor) ;see <sys/sysmacros.h>
+(define (device-number major minor) ; see glibc's <sys/sysmacros.h>
"Return the device number for the device with MAJOR and MINOR, for use as
the last argument of `mknod'."
- (+ (* major 256) minor))
+ (logior (ash (logand #x00000fff major) 8)
+ (ash (logand #xfffff000 major) 32)
+ (logand #x000000ff minor)
+ (ash (logand #xffffff00 minor) 12)))
-(define (device->major+minor device)
+(define (device->major+minor device) ; see glibc's <sys/sysmacros.h>
"Return two values: the major and minor device numbers that make up DEVICE."
- (values (ash device -8)
- (logand device #xff)))
+ (values (logior (ash (logand #x00000000000fff00 device) -8)
+ (ash (logand #xfffff00000000000 device) -32))
+ (logior (logand #x00000000000000ff device)
+ (ash (logand #x00000ffffff00000 device) -12))))
(define* (file->cpio-header file #:optional (file-name file)
#:key (stat lstat))
diff --git a/guix/docker.scm b/guix/docker.scm
index 889aaeacb5..a6f73d423c 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +22,7 @@
(define-module (guix docker)
#:use-module (gcrypt hash)
#:use-module (guix base16)
+ #:use-module (guix build pack)
#:use-module ((guix build utils)
#:select (mkdir-p
delete-file-recursively
@@ -58,8 +60,13 @@
(container_config . #nil)))
(define (canonicalize-repository-name name)
- "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+ "\"Repository\" names are restricted to roughly [a-z0-9_.-].
Return a version of TAG that follows these rules."
+ ;; Refer to https://docs.docker.com/docker-hub/repos/.
+ (define min-length 2)
+ (define padding-character #\a)
+ (define max-length 255)
+
(define ascii-letters
(string->char-set "abcdefghijklmnopqrstuvwxyz"))
@@ -69,11 +76,21 @@ Return a version of TAG that follows these rules."
(define repo-char-set
(char-set-union char-set:digit ascii-letters separators))
- (string-map (lambda (chr)
- (if (char-set-contains? repo-char-set chr)
- chr
- #\.))
- (string-trim (string-downcase name) separators)))
+ (define normalized-name
+ (string-map (lambda (chr)
+ (if (char-set-contains? repo-char-set chr)
+ chr
+ #\.))
+ (string-trim (string-downcase name) separators)))
+
+ (let ((l (string-length normalized-name)))
+ (match l
+ ((? (cut > <> max-length))
+ (string-take normalized-name max-length))
+ ((? (cut < <> min-length))
+ (string-append normalized-name
+ (make-string (- min-length l) padding-character)))
+ (_ normalized-name))))
(define* (manifest path id #:optional (tag "guix"))
"Generate a simple image manifest."
@@ -110,18 +127,6 @@ Return a version of TAG that follows these rules."
(rootfs . ((type . "layers")
(diff_ids . #(,(layer-diff-id layer)))))))
-(define %tar-determinism-options
- ;; GNU tar options to produce archives deterministically.
- '("--sort=name" "--mtime=@1"
- "--owner=root:0" "--group=root:0"
-
- ;; When 'build-docker-image' is passed store items, the 'nlink' of the
- ;; files therein 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. '--hard-dereference'
- ;; eliminates it.
- "--hard-dereference"))
-
(define directive-file
;; Return the file or directory created by a 'evaluate-populate-directive'
;; directive.
@@ -238,7 +243,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
(apply invoke "tar" "-cf" "../layer.tar"
`(,@transformation-options
- ,@%tar-determinism-options
+ ,@(tar-base-options)
,@paths
,@(scandir "."
(lambda (file)
@@ -273,9 +278,6 @@ SRFI-19 time-utc object, as the creation time in metadata."
(scm->json (repositories prefix id repository)))))
(apply invoke "tar" "-cf" image "-C" directory
- `(,@%tar-determinism-options
- ,@(if compressor
- (list "-I" (string-join compressor))
- '())
+ `(,@(tar-base-options #:compressor compressor)
"."))
(delete-file-recursively directory)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 3d8c2b9341..ff5ede2857 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -43,6 +44,7 @@
with-imported-modules
with-extensions
let-system
+ gexp->approximate-sexp
gexp-input
gexp-input?
@@ -163,6 +165,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
+ (($ <gexp-input> 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 "#<gexp " port)
@@ -2065,6 +2084,7 @@ This is the declarative counterpart of 'text-file*'."
(define build
(gexp (call-with-output-file (ungexp output "out")
(lambda (port)
+ (set-port-encoding! port "UTF-8")
(display (string-append (ungexp-splicing text)) port)))))
(computed-file name build))
diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm
index da00019297..e9a0179b3d 100644
--- a/guix/import/cabal.scm
+++ b/guix/import/cabal.scm
@@ -145,7 +145,7 @@ to the stack."
(lalr-parser
;; --- token definitions
(CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE
- (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY)
+ (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY)
(left: OR)
(left: PROPERTY AND)
(right: ELSE NOT))
@@ -155,6 +155,7 @@ to the stack."
(sections source-repo) : (append $1 (list $2))
(sections executables) : (append $1 $2)
(sections test-suites) : (append $1 $2)
+ (sections common) : (append $1 $2)
(sections custom-setup) : (append $1 $2)
(sections benchmarks) : (append $1 $2)
(sections lib-sec) : (append $1 (list $2))
@@ -178,6 +179,10 @@ to the stack."
(ts-sec) : (list $1))
(ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3)
(TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3))
+ (common (common common-sec) : (append $1 (list $2))
+ (common-sec) : (list $1))
+ (common-sec (COMMON OCURLY exprs CCURLY) : `(section common ,$1 ,$3)
+ (COMMON open exprs close) : `(section common ,$1 ,$3))
(custom-setup (CUSTOM-SETUP exprs) : (list `(section custom-setup ,$1 ,$2)))
(benchmarks (benchmarks bm-sec) : (append $1 (list $2))
(bm-sec) : (list $1))
@@ -367,6 +372,9 @@ matching a string against the created regexp."
(define is-test-suite (make-rx-matcher "^test-suite +([a-z0-9_-]+)"
regexp/icase))
+(define is-common (make-rx-matcher "^common +([a-z0-9_-]+)"
+ regexp/icase))
+
(define is-custom-setup (make-rx-matcher "^(custom-setup)"
regexp/icase))
@@ -394,7 +402,7 @@ matching a string against the created regexp."
(define (is-id s port)
(let ((cabal-reserved-words
'("if" "else" "library" "flag" "executable" "test-suite" "custom-setup"
- "source-repository" "benchmark"))
+ "source-repository" "benchmark" "common"))
(spaces (read-while (cut char-set-contains? char-set:blank <>) port))
(c (peek-char port)))
(unread-string spaces port)
@@ -469,6 +477,8 @@ string with the read characters."
(define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc))
+(define (lex-common common-rx-res loc) (lex-rx-res common-rx-res 'COMMON loc))
+
(define (lex-custom-setup ts-rx-res loc) (lex-rx-res ts-rx-res 'CUSTOM-SETUP loc))
(define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc))
@@ -570,6 +580,7 @@ the current port location."
((is-src-repo s) => (cut lex-src-repo <> loc))
((is-exec s) => (cut lex-exec <> loc))
((is-test-suite s) => (cut lex-test-suite <> loc))
+ ((is-common s) => (cut lex-common <> loc))
((is-custom-setup s) => (cut lex-custom-setup <> loc))
((is-benchmark s) => (cut lex-benchmark <> loc))
((is-lib s) (lex-lib loc))
@@ -796,7 +807,16 @@ the ordering operation and the version."
(let ((value (or (assoc-ref env name)
(assoc-ref (cabal-flags->alist (cabal-flags)) name))))
(if (eq? value 'false) #f #t)))
+
+ (define common-stanzas
+ (filter-map (match-lambda
+ (('section 'common common-name common)
+ (cons common-name common))
+ (_ #f))
+ cabal-sexp))
+
(define (eval sexp)
+ "Given an SEXP and an ENV, return the evaluated (SEXP . ENV)."
(match sexp
(() '())
;; nested 'if'
@@ -831,6 +851,9 @@ the ordering operation and the version."
(list 'section type name (eval parameters)))
(((? string? name) values)
(list name values))
+ ((("import" imports) rest ...)
+ (eval (append (append-map (cut assoc-ref common-stanzas <>) imports)
+ rest)))
((element rest ...)
(cons (eval element) (eval rest)))
(_ (raise (condition
diff --git a/guix/import/go.scm b/guix/import/go.scm
index d110954664..617a0d0e23 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,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)
@@ -145,20 +147,20 @@ name (e.g. \"github.com/golang/protobuf/proto\")."
;; Extract the text contained in a h2 child node of any
;; element marked with a "License" class attribute.
(select (sxpath `(// (* (@ (equal? (class "License"))))
- h2 // *text*))))
+ h2 // div // *text*))))
(select (html->sxml body #:strict? #t))))
(define (sxml->texi sxml-node)
"A very basic SXML to Texinfo converter which attempts to preserve HTML
formatting and links as text."
(sxml-match sxml-node
- ((strong ,text)
- (format #f "@strong{~a}" text))
- ((a (@ (href ,url)) ,text)
- (format #f "@url{~a,~a}" url text))
- ((code ,text)
- (format #f "@code{~a}" text))
- (,something-else something-else)))
+ ((strong ,text)
+ (format #f "@strong{~a}" text))
+ ((a (@ (href ,url)) ,text)
+ (format #f "@url{~a,~a}" url text))
+ ((code ,text)
+ (format #f "@code{~a}" text))
+ (,something-else something-else)))
(define (go-package-description name)
"Retrieve a short description for NAME, a Go package name,
@@ -186,8 +188,9 @@ e.g. \"google.golang.org/protobuf/proto\"."
(description (if (not (null? overview))
overview
(select-content sxml)))
- (description* (and (not (null? description))
- (first description))))
+ (description* (if (not (null? description))
+ (first description)
+ description)))
(match description*
(() #f) ;nothing selected
((p elements ...)
@@ -242,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 <vcs>
(%make-vcs url-prefix root-regex type)
vcs?
@@ -378,28 +391,28 @@ lists."
(define known-vcs
;; See the following URL for the official Go equivalent:
;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087
- (list
- (make-vcs
- "github.com"
- "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
- 'git)
- (make-vcs
- "bitbucket.org"
- "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
- 'unknown)
- (make-vcs
- "hub.jazz.net/git/"
- "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
- 'git)
- (make-vcs
- "git.apache.org"
- "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
- 'git)
- (make-vcs
- "git.openstack.org"
- "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
+ (list
+ (make-vcs
+ "github.com"
+ "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "bitbucket.org"
+ "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$"
+ 'unknown)
+ (make-vcs
+ "hub.jazz.net/git/"
+ "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "git.apache.org"
+ "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$"
+ 'git)
+ (make-vcs
+ "git.openstack.org"
+ "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\
(/[A-Za-z0-9_.\\-]+)*$"
- 'git)))
+ 'git)))
(define (module-path->repository-root module-path)
"Infer the repository root from a module path. Go modules can be
@@ -428,9 +441,9 @@ hence the need to derive this information."
(define* (go-module->guix-package-name module-path #:optional version)
"Converts a module's path to the canonical Guix format for Go packages.
Optionally include a VERSION string to append to the name."
- ;; Map dot, slash and underscore characters to hyphens.
+ ;; Map dot, slash, underscore and tilde characters to hyphens.
(let ((module-path* (string-map (lambda (c)
- (if (member c '(#\. #\/ #\_))
+ (if (member c '(#\. #\/ #\_ #\~))
#\-
c))
module-path)))
@@ -458,17 +471,21 @@ Optionally include a VERSION string to append to the name."
"Retrieve the module meta-data from its landing page. This is necessary
because goproxy servers don't currently provide all the information needed to
build a package."
+ (define (go-import->module-meta content-text)
+ (match (string-split content-text #\space)
+ ((root-path vcs repo-url)
+ (make-module-meta root-path (string->symbol vcs)
+ (strip-.git-suffix/maybe repo-url)))))
;; <meta name="go-import" content="import-prefix vcs repo-root">
(let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path)))
(select (sxpath `(// head (meta (@ (equal? (name "go-import"))))
// content))))
(match (select (html->sxml meta-data #:strict? #t))
(() #f) ;nothing selected
- (((content content-text))
- (match (string-split content-text #\space)
- ((root-path vcs repo-url)
- (make-module-meta root-path (string->symbol vcs)
- (strip-.git-suffix/maybe repo-url))))))))
+ ((('content content-text) ..1)
+ (find (lambda (meta)
+ (string-prefix? (module-meta-import-prefix meta) module-path))
+ (map go-import->module-meta content-text))))))
(define (module-meta-data-repo-url meta-data goproxy)
"Return the URL where the fetcher which will be used can download the
@@ -586,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/guix/import/opam.scm b/guix/import/opam.scm
index 0201376457..a35b01d277 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -66,7 +66,7 @@
(range #\# #\頋)))
(define-peg-pattern operator all (or "=" "!" "<" ">"))
-(define-peg-pattern records body (* (and (or record weird-record) (* SP))))
+(define-peg-pattern records body (and (* SP) (* (and (or record weird-record) (* SP)))))
(define-peg-pattern record all (and key COLON (* SP) value))
(define-peg-pattern weird-record all (and key (* SP) dict))
(define-peg-pattern key body (+ (or (range #\a #\z) "-")))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index e7457799ce..3affe1e920 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -56,6 +56,7 @@
edl1.0
epl1.0
epl2.0
+ eupl1.2
expat
freetype
freebsd-doc
@@ -307,6 +308,11 @@ at URI, which may be a file:// URI pointing the package's tree."
"https://www.eclipse.org/legal/epl-2.0/"
"https://www.gnu.org/licenses/license-list#EPL2"))
+(define eupl1.2
+ (license "EUPL 1.2"
+ "https://directory.fsf.org/wiki/License:EUPL-1.2"
+ "https://www.gnu.org/licenses/license-list#EUPL-1.2"))
+
(define expat
(license "Expat"
"http://directory.fsf.org/wiki/License:Expat"
diff --git a/guix/lint.scm b/guix/lint.scm
index 198e091f47..d76a2f5e03 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -13,6 +13,7 @@
;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,7 +41,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)
@@ -68,6 +70,7 @@
. guix:open-connection-for-uri)))
#:use-module (web request)
#:use-module (web response)
+ #:autoload (gnutls) (error->string)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-6) ;Unicode string ports
#:use-module (srfi srfi-9)
@@ -80,6 +83,7 @@
check-inputs-should-be-native
check-inputs-should-not-be-an-input-at-all
check-input-labels
+ check-wrapper-inputs
check-patch-file-names
check-patch-headers
check-synopsis-style
@@ -89,6 +93,7 @@
check-source
check-source-file-name
check-source-unstable-tarball
+ check-optional-tests
check-mirror-url
check-github-url
check-license
@@ -161,6 +166,78 @@
;;;
+;;; Procedures for analysing Scheme code in package definitions
+;;;
+
+(define* (find-procedure-body expression found
+ #:key (not-found (const '())))
+ "Try to find the body of the procedure defined inline by EXPRESSION.
+If it was found, call FOUND with its body. If it wasn't, call
+the thunk NOT-FOUND."
+ (match expression
+ (`(,(or 'let 'let*) . ,_)
+ (find-procedure-body (car (last-pair expression)) found
+ #:not-found not-found))
+ (`(,(or 'lambda 'lambda*) ,_ . ,code)
+ (found code))
+ (_ (not-found))))
+
+(define* (report-bogus-phase-deltas package bogus-deltas)
+ "Report a bogus invocation of ‘modify-phases’."
+ (list (make-warning package
+ ;; TRANSLATORS: 'modify-phases' is a Scheme syntax
+ ;; and should not be translated.
+ (G_ "incorrect call to ‘modify-phases’")
+ #:field 'arguments)))
+
+(define* (find-phase-deltas package found
+ #:key (not-found (const '()))
+ (bogus
+ (cut report-bogus-phase-deltas package <>)))
+ "Try to find the clauses of the ‘modify-phases’ form in the phases
+specification of PACKAGE. If they were found, all FOUND with a list
+of the clauses. If they weren't (e.g. because ‘modify-phases’ wasn't
+used at all), call the thunk NOT-FOUND instead. If ‘modify-phases’
+was used, but the clauses don't form a list, call BOGUS with the
+not-a-list."
+ (apply (lambda* (#:key phases #:allow-other-keys)
+ (define phases/sexp
+ (if (gexp? phases)
+ (gexp->approximate-sexp phases)
+ phases))
+ (match phases/sexp
+ (`(modify-phases ,_ . ,changes)
+ ((if (list? changes) found bogus) changes))
+ (_ (not-found))))
+ (package-arguments package)))
+
+(define (report-bogus-phase-procedure package)
+ "Report a syntactically-invalid phase clause."
+ (list (make-warning package
+ ;; TRANSLATORS: See ‘modify-phases’ in the manual.
+ (G_ "invalid phase clause")
+ #:field 'arguments)))
+
+(define* (find-phase-procedure package expression found
+ #:key (not-found (const '()))
+ (bogus (cut report-bogus-phase-procedure
+ package)))
+ "Try to find the procedure in the phase clause EXPRESSION. If it was
+found, call FOUND with the procedure expression. If EXPRESSION isn't
+actually a phase clause, call the thunk BOGUS. If the phase form doesn't
+have a procedure, call the thunk NOT-FOUND."
+ (match expression
+ (('add-after before after proc-expr)
+ (found proc-expr))
+ (('add-before after before proc-expr)
+ (found proc-expr))
+ (('replace _ proc-expr)
+ (found proc-expr))
+ (('delete _) (not-found))
+ (_ (bogus))))
+
+
+;;;
;;; Checkers
;;;
@@ -301,6 +378,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)
@@ -319,6 +405,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))
@@ -448,6 +535,49 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(inputs ,package-inputs)
(propagated-inputs ,package-propagated-inputs))))
+(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."
@@ -648,6 +778,51 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
(_
(values 'unknown-protocol #f)))))
+(define (call-with-networking-fail-safe message error-value proc)
+ "Call PROC catching any network-related errors. Upon a networking error,
+display a message including MESSAGE and return ERROR-VALUE."
+ (guard (c ((http-get-error? c)
+ (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
+ message
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
+ error-value))
+ (catch #t
+ proc
+ (match-lambda*
+ (('getaddrinfo-error errcode)
+ (warning (G_ "~a: host lookup failure: ~a~%")
+ message
+ (gai-strerror errcode))
+ error-value)
+ (('tls-certificate-error args ...)
+ (warning (G_ "~a: TLS certificate error: ~a")
+ message
+ (tls-certificate-error-string args))
+ error-value)
+ (('gnutls-error error function _ ...)
+ (warning (G_ "~a: TLS error in '~a': ~a~%")
+ message
+ function (error->string error))
+ error-value)
+ ((and ('system-error _ ...) args)
+ (let ((errno (system-error-errno args)))
+ (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
+ (let ((details (call-with-output-string
+ (lambda (port)
+ (print-exception port #f (car args)
+ (cdr args))))))
+ (warning (G_ "~a: ~a~%") message details)
+ error-value)
+ (apply throw args))))
+ (args
+ (apply throw args))))))
+
+(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
+ (call-with-networking-fail-safe message error-value
+ (lambda () exp ...)))
+
(define (tls-certificate-error-string args)
"Return a string explaining the 'tls-certificate-error' arguments ARGS."
(call-with-output-string
@@ -1066,15 +1241,17 @@ descriptions maintained upstream."
(eqv? (origin-method origin) url-fetch))
(filter-map
(lambda (uri)
- (and=> (follow-redirects-to-github uri)
+ (and=> (with-networking-fail-safe
+ (format #f (G_ "while accessing '~a'") uri)
+ #f
+ (follow-redirects-to-github uri))
(lambda (github-uri)
- (if (string=? github-uri uri)
- #f
- (make-warning
- package
- (G_ "URL should be '~a'")
- (list github-uri)
- #:field 'source)))))
+ (and (not (string=? github-uri uri))
+ (make-warning
+ package
+ (G_ "URL should be '~a'")
+ (list github-uri)
+ #:field 'source)))))
(origin-uris origin))
'())))
@@ -1082,6 +1259,37 @@ 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-procedure-body 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-check-procedure expression)
+ (find-procedure-body expression check-procedure-body))
+ (define (check-phases-delta delta)
+ (match delta
+ (`(replace 'check ,expression)
+ (check-check-procedure expression))
+ (_ '())))
+ (define (check-phases-deltas deltas)
+ (append-map check-phases-delta deltas))
+ (find-phase-deltas package check-phases-deltas))
+
(define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation."
(define (try store system)
@@ -1171,46 +1379,6 @@ of the propagated inputs it pulls in."
(make-warning package (G_ "invalid license field")
#:field 'license)))))
-(define (call-with-networking-fail-safe message error-value proc)
- "Call PROC catching any network-related errors. Upon a networking error,
-display a message including MESSAGE and return ERROR-VALUE."
- (guard (c ((http-get-error? c)
- (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
- message
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
- error-value))
- (catch #t
- proc
- (match-lambda*
- (('getaddrinfo-error errcode)
- (warning (G_ "~a: host lookup failure: ~a~%")
- message
- (gai-strerror errcode))
- error-value)
- (('tls-certificate-error args ...)
- (warning (G_ "~a: TLS certificate error: ~a")
- message
- (tls-certificate-error-string args))
- error-value)
- ((and ('system-error _ ...) args)
- (let ((errno (system-error-errno args)))
- (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
- (let ((details (call-with-output-string
- (lambda (port)
- (print-exception port #f (car args)
- (cdr args))))))
- (warning (G_ "~a: ~a~%") message details)
- error-value)
- (apply throw args))))
- (args
- (apply throw args))))))
-
-(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
- (call-with-networking-fail-safe message error-value
- (lambda () exp ...)))
-
(define (current-vulnerabilities*)
"Like 'current-vulnerabilities', but return the empty list upon networking
or HTTP errors. This allows network-less operation and makes problems with
@@ -1620,6 +1788,10 @@ them for PACKAGE."
(description "Identify input labels that do not match package names")
(check check-input-labels))
(lint-checker
+ (name 'wrapper-inputs)
+ (description "Make sure 'wrap-program' can finds its interpreter.")
+ (check check-wrapper-inputs))
+ (lint-checker
(name 'license)
;; TRANSLATORS: <license> is the name of a data type and must not be
;; translated.
@@ -1627,6 +1799,10 @@ them for PACKAGE."
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")
(check check-mirror-url))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index ebd671c82e..9494684228 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1150,7 +1150,7 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
(lambda (port)
(write
`(normal-top-level-add-to-load-path
- (list ,@subdirs))
+ (list ,@(delete-duplicates subdirs)))
port)
(newline port)
#t)))))))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 7c62b05d12..1707622c4f 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -28,6 +28,8 @@
#:use-module (guix utils)
#:use-module (guix grafts)
#:use-module (guix status)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -129,9 +131,16 @@ Perform the deployment specified by FILE.\n"))
(raise c))
((message-condition? c)
- (report-error (G_ "failed to deploy ~a: ~a~%")
- (machine-display-name machine)
- (condition-message c)))
+ (leave (G_ "failed to deploy ~a: ~a~%")
+ (machine-display-name machine)
+ (condition-message c)))
+ ((formatted-message? c)
+ (leave (G_ "failed to deploy ~a: ~a~%")
+ (machine-display-name machine)
+ (apply format #f
+ (gettext (formatted-message-string c)
+ %gettext-domain)
+ (formatted-message-arguments c))))
((deploy-error? c)
(when (deploy-error-should-roll-back c)
(info (G_ "rolling back ~a...~%")
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 4c7039cce9..38bc021665 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -7,6 +7,7 @@
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -67,6 +68,7 @@
%compressors
lookup-compressor
self-contained-tarball
+ debian-archive
docker-image
squashfs-image
@@ -179,22 +181,40 @@ dependencies are registered."
(computed-file "store-database" build
#:options `(#:references-graphs ,(zip labels items))))
-(define* (self-contained-tarball name profile
- #:key target
- (profile-name "guix-profile")
- deduplicate?
- entry-point
- (compressor (first %compressors))
- localstatedir?
- (symlinks '())
- (archiver tar))
- "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
-with a properly initialized store database.
+(define-syntax-rule (define-with-source (variable args ...) body body* ...)
+ "Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting
+its source property."
+ (begin
+ (define (variable args ...)
+ body body* ...)
+ (eval-when (load eval)
+ (set-procedure-property! variable 'source
+ '(define (variable args ...) body body* ...)))))
+
+(define-with-source (manifest->friendly-name manifest)
+ "Return a friendly name computed from the entries in MANIFEST, a
+<manifest> object."
+ (let loop ((names (map manifest-entry-name
+ (manifest-entries manifest))))
+ (define str (string-join names "-"))
+ (if (< (string-length str) 40)
+ str
+ (match names
+ ((_) str)
+ ((names ... _) (loop names))))))
-SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
-added to the pack."
+
+;;;
+;;; Tarball format.
+;;;
+(define* (self-contained-tarball/builder profile
+ #:key (profile-name "guix-profile")
+ (compressor (first %compressors))
+ localstatedir?
+ (symlinks '())
+ (archiver tar)
+ (extra-options '()))
+ "Return the G-Expression of the builder used for self-contained-tarball."
(define database
(and localstatedir?
(file-append (store-database (list profile))
@@ -216,126 +236,114 @@ added to the pack."
(and (not-config? module)
(not (equal? '(guix store deduplication) module))))
- (define build
- (with-imported-modules (source-module-closure
- `((guix build utils)
- (guix build union)
- (gnu build install))
- #:select? import-module?)
- #~(begin
- (use-modules (guix build utils)
- ((guix build union) #:select (relative-file-name))
- (gnu build install)
- (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 match))
+ (with-imported-modules (source-module-closure
+ `((guix build pack)
+ (guix build store-copy)
+ (guix build utils)
+ (guix build union)
+ (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)
+ (srfi srfi-1)
+ (srfi srfi-26)
+ (ice-9 match))
+
+ (define %root "root")
+
+ (define symlink->directives
+ ;; Return "populate directives" to make the given symlink and its
+ ;; parent directories.
+ (match-lambda
+ ((source '-> target)
+ (let ((target (string-append #$profile "/" target))
+ (parent (dirname source)))
+ ;; Never add a 'directory' directive for "/" so as to
+ ;; preserve its ownership when extracting the archive (see
+ ;; below), and also because this would lead to adding the
+ ;; same entries twice in the tarball.
+ `(,@(if (string=? parent "/")
+ '()
+ `((directory ,parent)))
+ (,source
+ -> ,(relative-file-name parent target)))))))
+
+ (define directives
+ ;; Fully-qualified symlinks.
+ (append-map symlink->directives '#$symlinks))
+
+ ;; Make sure non-ASCII file names are properly handled.
+ #+set-utf8-locale
+
+ (define tar #+(file-append archiver "/bin/tar"))
+
+ ;; Note: there is not much to gain here with deduplication and there
+ ;; is the overhead of the '.links' directory, so turn it off.
+ ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
+ ;; with hard links:
+ ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
+ (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)
+ directives)
+
+ ;; Create the tarball.
+ (with-directory-excursion %root
+ ;; 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 %root "root")
-
- (define symlink->directives
- ;; Return "populate directives" to make the given symlink and its
- ;; parent directories.
- (match-lambda
- ((source '-> target)
- (let ((target (string-append #$profile "/" target))
- (parent (dirname source)))
- ;; Never add a 'directory' directive for "/" so as to
- ;; preserve its ownnership when extracting the archive (see
- ;; below), and also because this would lead to adding the
- ;; same entries twice in the tarball.
- `(,@(if (string=? parent "/")
- '()
- `((directory ,parent)))
- (,source
- -> ,(relative-file-name parent target)))))))
-
- (define directives
- ;; Fully-qualified symlinks.
- (append-map symlink->directives '#$symlinks))
-
- ;; 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.
- (define tar-supports-sort?
- (zero? (system* (string-append #+archiver "/bin/tar")
- "cf" "/dev/null" "--files-from=/dev/null"
- "--sort=name")))
-
- ;; Make sure non-ASCII file names are properly handled.
- #+set-utf8-locale
-
- ;; Add 'tar' to the search path.
- (setenv "PATH" #+(file-append archiver "/bin"))
-
- ;; Note: there is not much to gain here with deduplication and there
- ;; is the overhead of the '.links' directory, so turn it off.
- ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
- ;; with hard links:
- ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
- (populate-single-profile-directory %root
- #:profile #$profile
- #:profile-name #$profile-name
- #:closure "profile"
- #:database #+database)
-
- ;; Create SYMLINKS.
- (for-each (cut evaluate-populate-directive <> %root)
- directives)
-
- ;; Create the tarball. Use GNU format so there's no file name
- ;; length limitation.
- (with-directory-excursion %root
- (exit
- (zero? (apply system* "tar"
- #+@(if (compressor-command compressor)
- #~("-I"
- (string-join
- #+(compressor-command compressor)))
- #~())
- "--format=gnu"
-
- ;; Avoid non-determinism in the archive. Use
- ;; mtime = 1, not zero, because that is what the
- ;; daemon does for files in the store (see the
- ;; 'mtimeStore' constant in local-store.cc.)
- (if tar-supports-sort? "--sort=name" "--mtime=@1")
- "--mtime=@1" ;for files in /var/guix
- "--owner=root:0"
- "--group=root:0"
-
- "--check-links"
- "-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))
-
- (delete-duplicates
- (filter-map (match-lambda
- (('directory directory)
- (string-append "." directory))
- ((source '-> _)
- (string-append "." source))
- (_ #f))
- directives)))))))))
+(define* (self-contained-tarball name profile
+ #:key target
+ (profile-name "guix-profile")
+ deduplicate?
+ entry-point
+ (compressor (first %compressors))
+ localstatedir?
+ (symlinks '())
+ (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
+with a properly initialized store database.
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
+added to the pack."
(when entry-point
(warning (G_ "entry point not supported in the '~a' format~%")
'tarball))
- (gexp->derivation (string-append name ".tar"
- (compressor-extension compressor))
- build
- #:target target
- #:references-graphs `(("profile" ,profile))))
+ (gexp->derivation
+ (string-append name ".tar"
+ (compressor-extension compressor))
+ (self-contained-tarball/builder profile
+ #:profile-name profile-name
+ #:compressor compressor
+ #:localstatedir? localstatedir?
+ #:symlinks symlinks
+ #:archiver archiver)
+ #: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."
@@ -362,6 +370,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")
@@ -369,7 +381,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.
@@ -536,6 +549,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")
@@ -543,7 +560,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
@@ -554,7 +572,7 @@ the image."
(file-append (store-database (list profile))
"/db/db.sqlite")))
- (define defmod 'define-module) ;trick Geiser
+ (define defmod 'define-module) ;trick Geiser
(define build
;; Guile-JSON and Guile-Gcrypt are required by (guix docker).
@@ -574,6 +592,8 @@ the image."
(srfi srfi-1) (srfi srfi-19)
(ice-9 match))
+ #$(procedure-source manifest->friendly-name)
+
(define environment
(map (match-lambda
((spec . value)
@@ -597,19 +617,6 @@ the image."
`((directory "/tmp" ,(getuid) ,(getgid) #o1777)
,@(append-map symlink->directives '#$symlinks)))
- (define tag
- ;; Compute a meaningful "repository" name, which will show up in
- ;; the output of "docker images".
- (let ((manifest (profile-manifest #$profile)))
- (let loop ((names (map manifest-entry-name
- (manifest-entries manifest))))
- (define str (string-join names "-"))
- (if (< (string-length str) 40)
- str
- (match names
- ((_) str)
- ((names ... _) (loop names))))))) ;drop one entry
-
(setenv "PATH" #+(file-append archiver "/bin"))
(build-docker-image #$output
@@ -617,7 +624,8 @@ the image."
(call-with-input-file "profile"
read-reference-graph))
#$profile
- #:repository tag
+ #:repository (manifest->friendly-name
+ (profile-manifest #$profile))
#:database #+database
#:system (or #$target %host-type)
#:environment environment
@@ -637,6 +645,192 @@ the image."
;;;
+;;; 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.
+(define* (debian-archive name profile
+ #:key target
+ (profile-name "guix-profile")
+ deduplicate?
+ entry-point
+ (compressor (first %compressors))
+ localstatedir?
+ (symlinks '())
+ (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
+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. 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).
+ (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)
+ ((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 #\-)))))
+
+ (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
+ ("i486" "i386")
+ ("i586" "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)
+
+ ;; 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').
+ (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
+Priority: optional
+Section: misc
+~%" 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"))
+
+ (apply invoke tar
+ `(,@(tar-base-options
+ #:tar tar
+ #:compressor #+(and=> compressor compressor-command))
+ "-cvf" ,control-tarball-file-name
+ "control"
+ ,@(if postinst-file '("postinst") '())
+ ,@(if triggers-file '("triggers") '())))
+
+ ;; 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.
;;;
@@ -967,7 +1161,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.
@@ -979,8 +1174,38 @@ 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 %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
@@ -1074,7 +1299,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)
@@ -1084,6 +1314,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_ "
@@ -1193,6 +1425,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 <local-file> 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)
@@ -1225,8 +1469,15 @@ Create a bundle of PACKAGE.\n"))
manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
- (name (string-append (symbol->string pack-format)
- "-pack"))
+ (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?
@@ -1260,7 +1511,10 @@ Create a bundle of PACKAGE.\n"))
(hooks (if bootstrap?
'()
%default-profile-hooks))
- (locales? (not bootstrap?)))))
+ (locales? (not bootstrap?))))
+ (name (string-append (manifest->friendly-name manifest)
+ "-" (symbol->string pack-format)
+ "-pack")))
(define (lookup-package package)
(manifest-lookup manifest (manifest-pattern (name package))))
@@ -1288,7 +1542,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/guix/scripts/package.scm b/guix/scripts/package.scm
index 694959d326..a34ecdcb54 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -9,6 +9,7 @@
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -831,15 +832,14 @@ processed, #f otherwise."
(map profile-manifest profiles)))
(installed (manifest-entries manifest)))
(leave-on-EPIPE
- (for-each (match-lambda
- (($ <manifest-entry> name version output path _)
- (when (or (not regexp)
- (regexp-exec regexp name))
- (format #t "~a\t~a\t~a\t~a~%"
- name (or version "?") output path))))
-
- ;; Show most recently installed packages last.
- (reverse installed))))
+ (let ((rows (filter-map
+ (match-lambda
+ (($ <manifest-entry> name version output path _)
+ (and (regexp-exec regexp name)
+ (list name (or version "?") output path))))
+ installed)))
+ ;; Show most recently installed packages last.
+ (pretty-print-table (reverse rows)))))
#t)
(('list-available regexp)
@@ -862,16 +862,15 @@ processed, #f otherwise."
result))
'())))
(leave-on-EPIPE
- (for-each (match-lambda
- ((name version outputs location)
- (format #t "~a\t~a\t~a\t~a~%"
- name version
- (string-join outputs ",")
- (location->string location))))
- (sort available
- (match-lambda*
- (((name1 . _) (name2 . _))
- (string<? name1 name2))))))
+ (let ((rows (map (match-lambda
+ ((name version outputs location)
+ (list name version (string-join outputs ",")
+ (location->string location))))
+ (sort available
+ (match-lambda*
+ (((name1 . _) (name2 . _))
+ (string<? name1 name2)))))))
+ (pretty-print-table rows)))
#t))
(('list-profiles _)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 07613240a8..fb8ce50fa7 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
@@ -44,20 +44,18 @@
#:select (with-file-lock/no-wait))
#:use-module (guix git)
#:use-module (git)
- #:use-module (gnu packages)
- #:use-module ((guix scripts package) #:select (build-and-use-profile
- delete-matching-generations))
- #:use-module ((gnu packages base) #:select (canonical-package))
- #:use-module (gnu packages guile)
- #:use-module ((gnu packages bootstrap)
- #:select (%bootstrap-guile))
- #:use-module ((gnu packages certs) #:select (le-certs))
+ #:autoload (gnu packages) (fold-available-packages)
+ #:autoload (guix scripts package) (build-and-use-profile
+ delete-matching-generations)
+ #:autoload (gnu packages base) (canonical-package)
+ #:autoload (gnu packages bootstrap) (%bootstrap-guile)
+ #:autoload (gnu packages certs) (le-certs)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
@@ -603,7 +601,7 @@ Return true when there is more package info to display."
(string-join lst ", ")))
(cut string-join <> ", ")))
- (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
+ (let ((new upgraded (new/upgraded-packages alist1 alist2)))
(define new-count (length new))
(define upgraded-count (length upgraded))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 3ea1c73e10..c044e1d47a 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -423,7 +423,7 @@ server certificates."
(list error/invalid-session
;; XXX: These two are not properly handled in
- ;; GnuTLS < 3.7.2, in
+ ;; GnuTLS < 3.7.3, in
;; 'write_to_session_record_port'; see
;; <https://bugs.gnu.org/47867>.
error/again error/interrupted)))
@@ -777,7 +777,7 @@ default value."
(loop))))))
((or ("-V") ("--version"))
(show-version-and-exit "guix substitute"))
- (("--help")
+ ((or ("-h") ("--help"))
(show-help))
(opts
(leave (G_ "~a: unrecognized options~%") opts))))))
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 39a818dd0b..49da6ecb16 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -308,12 +308,11 @@ ancestor of COMMIT, unless CHANNEL specifies a commit."
('self #t)
(_
(raise (make-compound-condition
- (condition
- (&message (message
- (format #f (G_ "\
+ (formatted-message (G_ "\
aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a")
- commit (channel-name channel)
- start)))
+ commit (channel-name channel)
+ start)
+ (condition
(&fix-hint
(hint (G_ "Use @option{--allow-downgrades} to force
this downgrade.")))))))))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 6d925d416c..06312d65a2 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -185,9 +186,12 @@ or #f if it could not be determined."
#:key display-missing?)
"Report the subset of ITEMS available as substitutes on SERVER.
When DISPLAY-MISSING? is true, display the list of missing substitutes.
-Return the coverage ratio, an exact number between 0 and 1."
+Return the coverage ratio, an exact number between 0 and 1.
+In case ITEMS is an empty list, return 1 instead."
(define MiB (* (expt 2 20) 1.))
+ ;; TRANSLATORS: it is quite possible zero store items are
+ ;; looked for.
(format #t (G_ "looking for ~h store items on ~a...~%")
(length items) server)
@@ -208,9 +212,10 @@ Return the coverage ratio, an exact number between 0 and 1."
narinfos))
(time (+ (time-second time)
(/ (time-nanosecond time) 1e9))))
- (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%")
- (* 100. (/ obtained requested 1.))
- obtained requested)
+ (when (> requested 0)
+ (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%")
+ (* 100. (/ obtained requested 1.))
+ obtained requested))
(let ((total (/ (reduce + 0 sizes) MiB)))
(match (length sizes)
((? zero?)
@@ -299,7 +304,9 @@ are queued~%")
;; Return the coverage ratio.
(let ((total (length items)))
- (/ (- total (length missing)) total)))))
+ (if (> total 0)
+ (/ (- total (length missing)) total)
+ 1)))))
;;;
diff --git a/guix/self.scm b/guix/self.scm
index 87d00ea64f..530632db7d 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -407,9 +407,8 @@ a list of extra files, such as '(\"contributing\")."
"\\.[a-z]{2}(_[A-Z]{2})?\\.po$")))
(define parallel-jobs
- ;; Limit thread creation by 'n-par-for-each'. Going beyond can
- ;; lead libgc 8.0.4 to abort with:
- ;; mmap(PROT_NONE) failed
+ ;; Limit thread creation by 'n-par-for-each', mostly to put an
+ ;; upper bound on memory usage.
(min (parallel-job-count) 4))
(mkdir #$output)
diff --git a/guix/status.scm b/guix/status.scm
index 1164c2a6e3..f351a56d92 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -558,7 +558,8 @@ substitutes being downloaded."
;; If there are no jobs running, we already reported download completion
;; so there's nothing left to do.
(unless (zero? (simultaneous-jobs status))
- (format port (success (G_ "substitution of ~a complete")) item))
+ (format port (success (G_ "substitution of ~a complete")) item)
+ (newline port))
(when (and print-urls? (zero? (simultaneous-jobs status)))
;; Leave a blank line after the "downloading ..." line and the
diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index 4987cda165..a5c554acff 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -37,7 +37,8 @@
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download)
#:select ((open-connection-for-uri
- . guix:open-connection-for-uri)))
+ . guix:open-connection-for-uri)
+ resolve-uri-reference))
#:use-module (guix progress)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
@@ -155,10 +156,12 @@ indicates that PATH is unavailable at CACHE-URL."
(define (narinfo-request cache-url path)
"Return an HTTP request for the narinfo of PATH at CACHE-URL."
- (let ((url (string-append cache-url "/" (store-path-hash-part path)
- ".narinfo"))
- (headers '((User-Agent . "GNU Guile"))))
- (build-request (string->uri url) #:method 'GET #:headers headers)))
+ (let* ((base (string->uri cache-url))
+ (ref (build-relative-ref
+ #:path (string-append (store-path-hash-part path) ".narinfo")))
+ (url (resolve-uri-reference ref base))
+ (headers '((User-Agent . "GNU Guile"))))
+ (build-request url #:method 'GET #:headers headers)))
(define (narinfo-from-file file url)
"Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
diff --git a/guix/ui.scm b/guix/ui.scm
index d3e01f846d..1428c254b3 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -16,6 +16,7 @@
;;; Copyright © 2019, 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -1889,10 +1890,10 @@ DURATION-RELATION with the current time."
(define (equal-entry? first second)
(string= (manifest-entry-item first) (manifest-entry-item second)))
- (define (display-entry entry prefix)
+ (define (make-row entry prefix)
(match entry
(($ <manifest-entry> name version output location _)
- (format #t " ~a ~a\t~a\t~a\t~a~%" prefix name version output location))))
+ (list (format #f " ~a ~a" prefix name) version output location))))
(define (list-entries number)
(manifest-entries (profile-manifest (generation-file-name profile number))))
@@ -1903,8 +1904,8 @@ DURATION-RELATION with the current time."
equal-entry? (list-entries new) (list-entries old)))
(removed (lset-difference
equal-entry? (list-entries old) (list-entries new))))
- (for-each (cut display-entry <> "+") added)
- (for-each (cut display-entry <> "-") removed)
+ (pretty-print-table (append (map (cut make-row <> "+") added)
+ (map (cut make-row <> "-") removed)))
(newline)))
(display-diff profile gen1 gen2))
@@ -1932,15 +1933,17 @@ already taken."
(define (display-profile-content profile number)
"Display the packages in PROFILE, generation NUMBER, in a human-readable
way."
- (for-each (match-lambda
- (($ <manifest-entry> name version output location _)
- (format #t " ~a\t~a\t~a\t~a~%"
- name version output location)))
- ;; Show most recently installed packages last.
- (reverse
- (manifest-entries
- (profile-manifest (generation-file-name profile number))))))
+ (define entry->row
+ (match-lambda
+ (($ <manifest-entry> name version output location _)
+ (list (string-append " " name) version output location))))
+
+ (let* ((manifest (profile-manifest (generation-file-name profile number)))
+ (entries (manifest-entries manifest))
+ (rows (map entry->row entries)))
+ ;; Show most recently installed packages last.
+ (pretty-print-table (reverse rows))))
(define (display-generation-change previous current)
(format #t (G_ "switched from generation ~a to ~a~%") previous current))
@@ -2139,16 +2142,14 @@ found."
(let ((command-main (module-ref module
(symbol-append 'guix- command))))
(parameterize ((program-name command))
- ;; Disable canonicalization so we don't don't stat unreasonably.
- (with-fluids ((%file-port-name-canonicalization #f))
- (dynamic-wind
- (const #f)
- (lambda ()
- (apply command-main args))
- (lambda ()
- ;; Abuse 'exit-hook' (which is normally meant to be used by the
- ;; REPL) to run things like profiling hooks upon completion.
- (run-hook exit-hook)))))))
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (apply command-main args))
+ (lambda ()
+ ;; Abuse 'exit-hook' (which is normally meant to be used by the
+ ;; REPL) to run things like profiling hooks upon completion.
+ (run-hook exit-hook))))))
(define (run-guix . args)
"Run the 'guix' command defined by command line ARGS.
@@ -2160,28 +2161,30 @@ and signal handling have already been set up."
;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it.
(set! %load-extensions '(".scm"))
- (match args
- (()
- (format (current-error-port)
- (G_ "guix: missing command name~%"))
- (show-guix-usage))
- ((or ("-h") ("--help"))
- (leave-on-EPIPE (show-guix-help)))
- ((or ("-V") ("--version"))
- (show-version-and-exit "guix"))
- (((? option? o) args ...)
- (format (current-error-port)
- (G_ "guix: unrecognized option '~a'~%") o)
- (show-guix-usage))
- (("help" command)
- (apply run-guix-command (string->symbol command)
- '("--help")))
- (("help" args ...)
- (leave-on-EPIPE (show-guix-help)))
- ((command args ...)
- (apply run-guix-command
- (string->symbol command)
- args))))
+ ;; Disable canonicalization so we don't don't stat unreasonably.
+ (with-fluids ((%file-port-name-canonicalization #f))
+ (match args
+ (()
+ (format (current-error-port)
+ (G_ "guix: missing command name~%"))
+ (show-guix-usage))
+ ((or ("-h") ("--help"))
+ (leave-on-EPIPE (show-guix-help)))
+ ((or ("-V") ("--version"))
+ (show-version-and-exit "guix"))
+ (((? option? o) args ...)
+ (format (current-error-port)
+ (G_ "guix: unrecognized option '~a'~%") o)
+ (show-guix-usage))
+ (("help" command)
+ (apply run-guix-command (string->symbol command)
+ '("--help")))
+ (("help" args ...)
+ (leave-on-EPIPE (show-guix-help)))
+ ((command args ...)
+ (apply run-guix-command
+ (string->symbol command)
+ args)))))
(define (guix-main arg0 . args)
(initialize-guix)
diff --git a/guix/utils.scm b/guix/utils.scm
index b75710eb0d..c5a3a52f9d 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -12,6 +12,8 @@
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -135,7 +137,9 @@
canonical-newline-port
string-distance
- string-closest))
+ string-closest
+
+ pretty-print-table))
;;;
@@ -1062,6 +1066,33 @@ according to THRESHOLD, then #f is returned."
#f +inf.0
tests)))
+
+;;;
+;;; Prettified output.
+;;;
+
+(define* (pretty-print-table rows #:key (max-column-width 20))
+ "Print ROWS in neat columns. All rows should be lists of strings and each
+row should have the same length. The columns are separated by a tab
+character, and aligned using spaces. The maximum width of each column is
+bound by MAX-COLUMN-WIDTH."
+ (let* ((number-of-columns-to-pad (if (null? rows)
+ 0
+ (1- (length (first rows)))))
+ ;; Ignore the last column as it is left aligned and doesn't need
+ ;; padding; this prevents printing extraneous trailing spaces.
+ (column-widths (fold (lambda (row maximums)
+ (map max (map string-length row) maximums))
+ ;; Initial max width is 0 for each column.
+ (make-list number-of-columns-to-pad 0)
+ (map (cut drop-right <> 1) rows)))
+ (column-formats (map (cut format #f "~~~da" <>)
+ (map (cut min <> max-column-width)
+ column-widths)))
+ (fmt (string-append (string-join column-formats "\t") "\t~a")))
+ (setvbuf (current-output-port) 'block) ;for better performance
+ (for-each (cut format #t "~?~%" fmt <>) rows)))
+
;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
;;; End:
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-10 09:31:01 +0000