summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2019-10-08 19:24:34 +0200
committerMarius Bakke <mbakke@fastmail.com>2019-10-08 19:24:34 +0200
commitd1f3b333e6176a7879ab3742bbebb2a99f61a528 (patch)
tree8bd82ce68bd2534a48bf13c7256997f82dd1b3f4 /guix
parente01d384efcdaf564bbb221e43b81e087c8e2af06 (diff)
parent861907f01efb1cae7f260e8cb7b991d5034a486a (diff)
downloadguix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar
guix-patches-d1f3b333e6176a7879ab3742bbebb2a99f61a528.tar.gz
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cargo.scm11
-rw-r--r--guix/build-system/cmake.scm2
-rw-r--r--guix/build-system/julia.scm130
-rw-r--r--guix/build-system/meson.scm2
-rw-r--r--guix/build-system/r.scm20
-rw-r--r--guix/build/cargo-build-system.scm38
-rw-r--r--guix/build/compile.scm9
-rw-r--r--guix/build/gnu-build-system.scm130
-rw-r--r--guix/build/go-build-system.scm2
-rw-r--r--guix/build/julia-build-system.scm135
-rw-r--r--guix/build/lisp-utils.scm14
-rw-r--r--guix/build/make-bootstrap.scm72
-rw-r--r--guix/build/meson-build-system.scm1
-rw-r--r--guix/build/python-build-system.scm33
-rw-r--r--guix/build/ruby-build-system.scm2
-rw-r--r--guix/build/syscalls.scm44
-rw-r--r--guix/build/utils.scm230
-rw-r--r--guix/bzr-download.scm3
-rw-r--r--guix/channels.scm223
-rw-r--r--guix/ci.scm68
-rw-r--r--guix/colors.scm18
-rw-r--r--guix/cvs-download.scm5
-rw-r--r--guix/derivations.scm6
-rw-r--r--guix/diagnostics.scm7
-rw-r--r--guix/docker.scm111
-rw-r--r--guix/download.scm28
-rw-r--r--guix/gexp.scm150
-rw-r--r--guix/git-download.scm10
-rw-r--r--guix/git.scm58
-rw-r--r--guix/gnu-maintenance.scm44
-rw-r--r--guix/hg-download.scm5
-rw-r--r--guix/import/cran.scm296
-rw-r--r--guix/import/crate.scm186
-rw-r--r--guix/import/github.scm10
-rw-r--r--guix/import/gnome.scm35
-rw-r--r--guix/import/kde.scm190
-rw-r--r--guix/import/opam.scm6
-rw-r--r--guix/import/pypi.scm3
-rw-r--r--guix/import/stackage.scm2
-rw-r--r--guix/import/utils.scm22
-rw-r--r--guix/inferior.scm37
-rw-r--r--guix/json.scm62
-rw-r--r--guix/lint.scm172
-rw-r--r--guix/packages.scm56
-rw-r--r--guix/remote.scm76
-rw-r--r--guix/repl.scm6
-rw-r--r--guix/scripts/container/exec.scm2
-rw-r--r--guix/scripts/deploy.scm52
-rw-r--r--guix/scripts/describe.scm27
-rw-r--r--guix/scripts/download.scm15
-rw-r--r--guix/scripts/environment.scm42
-rw-r--r--guix/scripts/gc.scm15
-rw-r--r--guix/scripts/import.scm4
-rw-r--r--guix/scripts/import/cran.scm9
-rw-r--r--guix/scripts/import/crate.scm41
-rw-r--r--guix/scripts/lint.scm6
-rw-r--r--guix/scripts/offload.scm3
-rw-r--r--guix/scripts/pack.scm93
-rw-r--r--guix/scripts/package.scm30
-rw-r--r--guix/scripts/pull.scm242
-rw-r--r--guix/scripts/refresh.scm57
-rw-r--r--guix/scripts/search.scm11
-rw-r--r--guix/scripts/show.scm76
-rw-r--r--guix/scripts/system.scm6
-rw-r--r--guix/self.scm7
-rw-r--r--guix/ssh.scm56
-rw-r--r--guix/store/roots.scm129
-rw-r--r--guix/svn-download.scm5
-rw-r--r--guix/swh.scm186
-rw-r--r--guix/tests.scm68
-rw-r--r--guix/tests/git.scm105
-rw-r--r--guix/tests/http.scm39
-rw-r--r--guix/ui.scm106
-rw-r--r--guix/upstream.scm21
-rw-r--r--guix/utils.scm7
75 files changed, 3323 insertions, 907 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index 10a1bac844..1e8b3a578e 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
@@ -35,12 +35,17 @@
#:export (%cargo-build-system-modules
%cargo-utils-modules
cargo-build-system
+ %crate-base-url
crate-url
crate-url?
crate-uri))
-(define crate-url "https://crates.io/api/v1/crates/")
-(define crate-url? (cut string-prefix? crate-url <>))
+(define %crate-base-url
+ (make-parameter "https://crates.io"))
+(define crate-url
+ (string-append (%crate-base-url) "/api/v1/crates/"))
+(define crate-url?
+ (cut string-prefix? crate-url <>))
(define (crate-uri name version)
"Return a URI string for the crate package hosted at crates.io corresponding
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index ee116c5a4c..ca88fadddf 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -48,7 +48,7 @@
;; Do not use `@' to avoid introducing circular dependencies.
(let ((module (resolve-interface '(gnu packages cmake))))
- (module-ref module 'cmake)))
+ (module-ref module 'cmake-minimal)))
(define* (lower name
#:key source inputs native-inputs outputs system target
diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm
new file mode 100644
index 0000000000..488fe9bb1d
--- /dev/null
+++ b/guix/build-system/julia.scm
@@ -0,0 +1,130 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
+;;;
+;;; 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-system julia)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-26)
+ #:export (%julia-build-system-modules
+ julia-build
+ julia-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for Julia packages.
+;;
+;; Code:
+
+(define %julia-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build julia-build-system)
+ ,@%gnu-build-system-modules))
+
+(define (default-julia)
+ "Return the default Julia package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((julia-mod (resolve-interface '(gnu packages julia))))
+ (module-ref julia-mod 'julia)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (julia (default-julia))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:target #:julia #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("julia" ,julia)
+ ,@native-inputs))
+ (outputs outputs)
+ (build julia-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (julia-build store name inputs
+ #:key source
+ (tests? #f)
+ (phases '(@ (guix build julia-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %julia-build-system-modules)
+ (modules '((guix build julia-build-system)
+ (guix build utils))))
+ "Build SOURCE using Julia, and with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (julia-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define julia-build-system
+ (build-system
+ (name 'julia)
+ (description "The build system for Julia packages")
+ (lower lower)))
+
+;;; julia.scm ends here
diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm
index 370d185545..b29f2f4ecf 100644
--- a/guix/build-system/meson.scm
+++ b/guix/build-system/meson.scm
@@ -90,7 +90,7 @@
(outputs '("out"))
(configure-flags ''())
(search-paths '())
- (build-type "plain")
+ (build-type "debugoptimized")
(tests? #t)
(test-target "test")
(glib-or-gtk? #f)
diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm
index e7214155be..dd2a9fe8de 100644
--- a/guix/build-system/r.scm
+++ b/guix/build-system/r.scm
@@ -47,14 +47,22 @@ available via the first URI, the second URI points to the archived version."
(string-append "mirror://cran/src/contrib/Archive/"
name "/" name "_" version ".tar.gz")))
-(define (bioconductor-uri name version)
+(define* (bioconductor-uri name version #:optional type)
"Return a URI string for the R package archive on Bioconductor for the
release corresponding to NAME and VERSION."
- (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/"
- name "_" version ".tar.gz")
- ;; TODO: use %bioconductor-version from (guix import cran)
- (string-append "https://bioconductor.org/packages/3.9/bioc/src/contrib/Archive/"
- name "_" version ".tar.gz")))
+ (let ((type-url-part (match type
+ ('annotation "/data/annotation")
+ ('experiment "/data/experiment")
+ (_ "/bioc"))))
+ (list (string-append "https://bioconductor.org/packages/release"
+ type-url-part
+ "/src/contrib/"
+ name "_" version ".tar.gz")
+ ;; TODO: use %bioconductor-version from (guix import cran)
+ (string-append "https://bioconductor.org/packages/3.9"
+ type-url-part
+ "/src/contrib/Archive/"
+ name "_" version ".tar.gz"))))
(define %r-build-system-modules
;; Build-side modules imported by default.
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 8aa9390457..8a8d74ee1b 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -66,10 +66,10 @@ Cargo.toml file present at its root."
;; archive, but not nested anywhere else). We do this by cutting up
;; each output line and only looking at the second component. We then
;; check if it matches Cargo.toml exactly and short circuit if it does.
- (zero? (apply system* (list "sh" "-c"
- (string-append "tar -tf " path
- " | cut -d/ -f2"
- " | grep -q '^Cargo.toml$'"))))))
+ (apply invoke (list "sh" "-c"
+ (string-append "tar -tf " path
+ " | cut -d/ -f2"
+ " | grep -q '^Cargo.toml$'")))))
(define* (configure #:key inputs
(vendor-dir "guix-vendor")
@@ -84,7 +84,7 @@ Cargo.toml file present at its root."
(for-each
(match-lambda
((name . path)
- (let* ((basepath (basename path))
+ (let* ((basepath (strip-store-file-name path))
(crate-dir (string-append vendor-dir "/" basepath)))
(and (crate-src? path)
;; Gracefully handle duplicate inputs
@@ -119,22 +119,12 @@ directory = '" port)
;; upgrading the compiler for example.
(setenv "RUSTFLAGS" "--cap-lints allow")
(setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
- #t)
-;; The Cargo.lock file tells the build system which crates are required for
-;; building and hardcodes their version and checksum. In order to build with
-;; the inputs we provide, we need to recreate the file with our inputs.
-(define* (update-cargo-lock #:key
- (vendor-dir "guix-vendor")
- #:allow-other-keys)
- "Regenerate the Cargo.lock file with the current build inputs."
+ ;; We don't use the Cargo.lock file to determine the package versions we use
+ ;; during building, and in any case if one is not present it is created
+ ;; during the 'build phase by cargo.
(when (file-exists? "Cargo.lock")
- (begin
- ;; Unfortunately we can't generate a Cargo.lock file until the checksums
- ;; are generated, so we have an extra round of generate-all-checksums here.
- (generate-all-checksums vendor-dir)
- (delete-file "Cargo.lock")
- (invoke "cargo" "generate-lockfile")))
+ (delete-file "Cargo.lock"))
#t)
;; After the 'patch-generated-file-shebangs phase any vendored crates who have
@@ -152,7 +142,7 @@ directory = '" port)
#:allow-other-keys)
"Build a given Cargo package."
(or skip-build?
- (zero? (apply system* `("cargo" "build" ,@cargo-build-flags)))))
+ (apply invoke `("cargo" "build" ,@cargo-build-flags))))
(define* (check #:key
tests?
@@ -160,12 +150,9 @@ directory = '" port)
#:allow-other-keys)
"Run tests for a given Cargo package."
(if tests?
- (zero? (apply system* `("cargo" "test" ,@cargo-test-flags)))
+ (apply invoke `("cargo" "test" ,@cargo-test-flags))
#t))
-(define (touch file-name)
- (call-with-output-file file-name (const #t)))
-
(define* (install #:key inputs outputs skip-build? #:allow-other-keys)
"Install a given Cargo package."
(let* ((out (assoc-ref outputs "out")))
@@ -179,7 +166,7 @@ directory = '" port)
;; otherwise cargo will raise an error.
(or skip-build?
(not (has-executable-target?))
- (zero? (system* "cargo" "install" "--path" "." "--root" out)))))
+ (invoke "cargo" "install" "--path" "." "--root" out))))
(define %standard-phases
(modify-phases gnu:%standard-phases
@@ -188,7 +175,6 @@ directory = '" port)
(replace 'build build)
(replace 'check check)
(replace 'install install)
- (add-after 'configure 'update-cargo-lock update-cargo-lock)
(add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums)))
(define* (cargo-build #:key inputs (phases %standard-phases)
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index c127456fd0..06ed57c9d7 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -169,11 +169,12 @@ BUILD-DIRECTORY, using up to WORKERS parallel workers. The resulting object
files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
(define progress-lock (make-mutex))
(define total (length files))
- (define completed 0)
+ (define progress 0)
(define (build file)
(with-mutex progress-lock
- (report-compilation file total completed))
+ (report-compilation file total progress)
+ (set! progress (+ 1 progress)))
;; Exit as soon as something goes wrong.
(exit-on-exception
@@ -185,9 +186,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
#:output-file (string-append build-directory "/"
(scm->go relative))
#:opts (append warning-options
- (optimization-options relative)))))))
- (with-mutex progress-lock
- (set! completed (+ 1 completed))))
+ (optimization-options relative))))))))
(with-augmented-search-path %load-path source-directory
(with-augmented-search-path %load-compiled-path build-directory
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index e5f3197b0a..4df0bb4904 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -25,6 +25,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-34)
@@ -58,19 +59,14 @@ See https://reproducible-builds.org/specs/source-date-epoch/."
(setenv "SOURCE_DATE_EPOCH" "1")
#t)
-(define (first-subdirectory dir)
- "Return the path of the first sub-directory of DIR."
- (file-system-fold (lambda (path stat result)
- (string=? path dir))
- (lambda (path stat result) result) ; leaf
- (lambda (path stat result) result) ; down
- (lambda (path stat result) result) ; up
- (lambda (path stat result) ; skip
- (or result path))
- (lambda (path stat errno result) ; error
- (error "first-subdirectory" (strerror errno)))
- #f
- dir))
+(define (first-subdirectory directory)
+ "Return the file name of the first sub-directory of DIRECTORY."
+ (match (scandir directory
+ (lambda (file)
+ (and (not (member file '("." "..")))
+ (file-is-directory? (string-append directory "/"
+ file)))))
+ ((first . _) first)))
(define* (set-paths #:key target inputs native-inputs
(search-paths '()) (native-search-paths '())
@@ -735,23 +731,64 @@ which cannot be found~%"
(define* (install-license-files #:key outputs
(license-file-regexp %license-file-regexp)
+ out-of-source?
#:allow-other-keys)
"Install license files matching LICENSE-FILE-REGEXP to 'share/doc'."
+ (define (find-source-directory package)
+ ;; For an out-of-source build, guess the source directory location
+ ;; relative to the current directory. Return #f on failure.
+ (match (scandir ".."
+ (lambda (file)
+ (and (not (member file '("." ".." "build")))
+ (file-is-directory?
+ (string-append "../" file)))))
+ (() ;hmm, no source
+ #f)
+ ((source) ;only one other file
+ (string-append "../" source))
+ ((directories ...) ;pick the most likely one
+ ;; This happens for example with libstdc++, which lives within the GCC
+ ;; source tree.
+ (any (lambda (directory)
+ (and (string-prefix? package directory)
+ (string-append "../" directory)))
+ directories))))
+
+ (define (copy-to-directories directories sub-directory)
+ (lambda (file)
+ (for-each (if (file-is-directory? file)
+ (cut copy-recursively file <>)
+ (cut install-file file <>))
+ (map (cut string-append <> "/" sub-directory)
+ directories))))
+
(let* ((regexp (make-regexp license-file-regexp))
(out (or (assoc-ref outputs "out")
(match outputs
(((_ . output) _ ...)
output))))
(package (strip-store-file-name out))
- (directory (string-append out "/share/doc/" package))
- (files (scandir "." (lambda (file)
- (regexp-exec regexp file)))))
- (format #t "installing ~a license files~%" (length files))
- (for-each (lambda (file)
- (if (file-is-directory? file)
- (copy-recursively file directory)
- (install-file file directory)))
- files)
+ (outputs (match outputs
+ (((_ . outputs) ...)
+ outputs)))
+ (source (if out-of-source?
+ (find-source-directory
+ (package-name->name+version package))
+ "."))
+ (files (and source
+ (scandir source
+ (lambda (file)
+ (regexp-exec regexp file))))))
+ (if files
+ (begin
+ (format #t "installing ~a license files from '~a'~%"
+ (length files) source)
+ (for-each (copy-to-directories outputs
+ (string-append "share/doc/"
+ package))
+ (map (cut string-append source "/" <>) files)))
+ (format (current-error-port)
+ "failed to find license files~%"))
#t))
(define %standard-phases
@@ -784,34 +821,37 @@ in order. Return #t if all the PHASES succeeded, #f otherwise."
(+ (time-second diff)
(/ (time-nanosecond diff) 1e9))))
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
+ (setvbuf (current-output-port) 'line)
+ (setvbuf (current-error-port) 'line)
;; Encoding/decoding errors shouldn't be silent.
(fluid-set! %default-port-conversion-strategy 'error)
- ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
- ;; PHASES can pick the keyword arguments it's interested in.
- (every (match-lambda
- ((name . proc)
- (let ((start (current-time time-monotonic)))
- (format #t "starting phase `~a'~%" name)
- (let ((result (apply proc args))
- (end (current-time time-monotonic)))
- (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
- name result
- (elapsed-time end start))
-
- ;; Issue a warning unless the result is #t.
- (unless (eqv? result #t)
- (format (current-error-port) "\
+ (guard (c ((invoke-error? c)
+ (report-invoke-error c)
+ (exit 1)))
+ ;; The trick is to #:allow-other-keys everywhere, so that each procedure in
+ ;; PHASES can pick the keyword arguments it's interested in.
+ (every (match-lambda
+ ((name . proc)
+ (let ((start (current-time time-monotonic)))
+ (format #t "starting phase `~a'~%" name)
+ (let ((result (apply proc args))
+ (end (current-time time-monotonic)))
+ (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%"
+ name result
+ (elapsed-time end start))
+
+ ;; Issue a warning unless the result is #t.
+ (unless (eqv? result #t)
+ (format (current-error-port) "\
## WARNING: phase `~a' returned `~s'. Return values other than #t
## are deprecated. Please migrate this package so that its phase
## procedures report errors by raising an exception, and otherwise
## always return #t.~%"
- name result))
+ name result))
- ;; Dump the environment variables as a shell script, for handy debugging.
- (system "export > $NIX_BUILD_TOP/environment-variables")
- result))))
- phases))
+ ;; Dump the environment variables as a shell script, for handy debugging.
+ (system "export > $NIX_BUILD_TOP/environment-variables")
+ result))))
+ phases)))
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 3dac43c18a..4bc0156a88 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -237,7 +237,7 @@ unpacking."
"Install the source code of IMPORT-PATH to the primary output directory.
Compiled executable files (Go \"commands\") should have already been installed
to the store based on $GOBIN in the build phase.
-XXX We can't make us of compiled libraries (Go \"packages\")."
+XXX We can't make use of compiled libraries (Go \"packages\")."
(when install-source?
(if (string-null? import-path)
((display "WARNING: The Go import path is unset.\n")))
diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm
new file mode 100644
index 0000000000..ff6fcf5fe3
--- /dev/null
+++ b/guix/build/julia-build-system.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Nicolò Balzarotti <nicolo@nixo.xyz>
+;;;
+;;; 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 julia-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 match)
+ #:export (%standard-phases
+ julia-create-package-toml
+ julia-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard build procedure for Julia packages.
+;;
+;; Code:
+
+(define (invoke-julia code)
+ (invoke "julia" "-e" code))
+
+;; subpath where we store the package content
+(define %package-path "/share/julia/packages/")
+
+(define (generate-load-path inputs outputs)
+ (string-append
+ (string-join (map (match-lambda
+ ((_ . path)
+ (string-append path %package-path)))
+ ;; Restrict to inputs beginning with "julia-".
+ (filter (match-lambda
+ ((name . _)
+ (string-prefix? "julia-" name)))
+ inputs))
+ ":")
+ (string-append ":" (assoc-ref outputs "out") %package-path)
+ ;; stdlib is always required to find Julia's standard libraries.
+ ;; usually there are other two paths in this variable:
+ ;; "@" and "@v#.#"
+ ":@stdlib"))
+
+(define* (install #:key source inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (package-dir (string-append out %package-path
+ (string-append
+ (strip-store-file-name source)))))
+ (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+ (mkdir-p package-dir)
+ (copy-recursively source package-dir))
+ #t)
+
+;; TODO: Precompilation is working, but I don't know how to tell
+;; julia to use use it. If (on rantime) we set HOME to
+;; store path, julia tries to write files there (failing)
+(define* (precompile #:key source inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (builddir (string-append out "/share/julia/"))
+ (package (strip-store-file-name source)))
+ (mkdir-p builddir)
+ (setenv "JULIA_DEPOT_PATH" builddir)
+ (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+ ;; Actual precompilation
+ (invoke-julia (string-append "using " package)))
+ #t)
+
+(define* (check #:key source inputs outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (package (strip-store-file-name source))
+ (builddir (string-append out "/share/julia/")))
+ (setenv "JULIA_DEPOT_PATH" builddir)
+ (setenv "JULIA_LOAD_PATH" (generate-load-path inputs outputs))
+ (invoke-julia (string-append "using Pkg;Pkg.test(\"" package "\")")))
+ #t)
+
+(define (julia-create-package-toml outputs source
+ name uuid version
+ deps)
+ "Some packages are not using the new Package.toml dependency specifications.
+Write this file manually, so that Julia can find its dependencies."
+ (let ((f (open-file
+ (string-append
+ (assoc-ref outputs "out")
+ %package-path
+ (string-append
+ name "/Project.toml"))
+ "w")))
+ (display (string-append
+ "
+name = \"" name "\"
+uuid = \"" uuid "\"
+version = \"" version "\"
+") f)
+ (when (not (null? deps))
+ (display "[deps]\n" f)
+ (for-each (lambda dep
+ (display (string-append (car (car dep)) " = \"" (cdr (car dep)) "\"\n")
+ f))
+ deps))
+ (close-port f))
+ #t)
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'check) ; tests must be run after installation
+ (replace 'install install)
+ (add-after 'install 'precompile precompile)
+ ;; (add-after 'install 'check check)
+ ;; TODO: In the future we could add a "system-image-generation" phase
+ ;; where we use PackageCompiler.jl to speed up package loading times
+ (delete 'configure)
+ (delete 'bootstrap)
+ (delete 'patch-usr-bin-file)
+ (delete 'build)))
+
+(define* (julia-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given Julia package, applying all of PHASES in order."
+ (apply gnu:gnu-build
+ #:inputs inputs #:phases phases
+ args))
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 97bc6197a3..c7a589c902 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -220,12 +220,19 @@ Also load TEST-ASD-FILE if necessary."
"Return a lisp keyword for the concatenation of STRINGS."
(string->symbol (apply string-append ":" strings)))
-(define (generate-executable-for-system type system)
+(define* (generate-executable-for-system type system #:key compress?)
"Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
'asdf:program-op. The latter will always be standalone. Depends on having
created a \"SYSTEM-exec\" system which contains the entry program."
(lisp-eval-program
`((require :asdf)
+ ;; Only SBCL supports compression as of 2019-09-02.
+ ,(if (and compress? (string=? (%lisp-type) "sbcl"))
+ '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
+ (uiop:dump-image (asdf:output-file o c)
+ :executable t
+ :compression t))
+ '())
(asdf:operate ',type ,(string-append system "-exec")))))
(define (generate-executable-wrapper-system system dependencies)
@@ -339,6 +346,7 @@ which are not nested."
(dependency-prefixes (list (library-output outputs)))
(dependencies (list (basename program)))
entry-program
+ compress?
#:allow-other-keys)
"Generate an executable program containing all DEPENDENCIES, and which will
execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it
@@ -350,6 +358,7 @@ retained."
#:dependencies dependencies
#:dependency-prefixes dependency-prefixes
#:entry-program entry-program
+ #:compress? compress?
#:type 'asdf:program-op)
(let* ((name (basename program))
(bin-directory (dirname program)))
@@ -382,6 +391,7 @@ DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
dependency-prefixes
entry-program
type
+ compress?
#:allow-other-keys)
"Generate an executable by using asdf operation TYPE, containing whithin the
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
@@ -405,7 +415,7 @@ references to those libraries are retained."
`(((,bin-directory :**/ :*.*.*)
(,bin-directory :**/ :*.*.*)))))))
- (generate-executable-for-system type name)
+ (generate-executable-for-system type name #:compress? compress?)
(let* ((after-store-prefix-index
(string-index out-file #\/
diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm
index 48799f7e90..e5ef1d6d2b 100644
--- a/guix/build/make-bootstrap.scm
+++ b/guix/build/make-bootstrap.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,7 +24,8 @@
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (guix build utils)
- #:export (make-stripped-libc))
+ #:export (copy-linux-headers
+ make-stripped-libc))
;; Commentary:
;;
@@ -31,6 +33,53 @@
;;
;; Code:
+(define (copy-linux-headers output kernel-headers)
+ "Copy to OUTPUT the subset of KERNEL-HEADERS that is needed when producing a
+bootstrap libc."
+
+ (let* ((incdir (string-append output "/include")))
+ (mkdir-p incdir)
+
+ ;; Copy some of the Linux-Libre headers that glibc headers
+ ;; refer to.
+ (mkdir (string-append incdir "/linux"))
+ (for-each (lambda (file)
+ (install-file (pk 'src (string-append kernel-headers "/include/linux/" file))
+ (pk 'dest (string-append incdir "/linux"))))
+ '(
+ "a.out.h" ; for 2.2.5
+ "atalk.h" ; for 2.2.5
+ "errno.h"
+ "falloc.h"
+ "if_addr.h" ; for 2.16.0
+ "if_ether.h" ; for 2.2.5
+ "if_link.h" ; for 2.16.0
+ "ioctl.h"
+ "kernel.h"
+ "limits.h"
+ "neighbour.h" ; for 2.16.0
+ "netlink.h" ; for 2.16.0
+ "param.h"
+ "prctl.h" ; for 2.16.0
+ "posix_types.h"
+ "rtnetlink.h" ; for 2.16.0
+ "socket.h"
+ "stddef.h"
+ "swab.h" ; for 2.2.5
+ "sysctl.h"
+ "sysinfo.h" ; for 2.2.5
+ "types.h"
+ "version.h" ; for 2.2.5
+ ))
+
+ (copy-recursively (string-append kernel-headers "/include/asm")
+ (string-append incdir "/asm"))
+ (copy-recursively (string-append kernel-headers "/include/asm-generic")
+ (string-append incdir "/asm-generic"))
+ (copy-recursively (string-append kernel-headers "/include/linux/byteorder")
+ (string-append incdir "/linux/byteorder"))
+ #t))
+
(define (make-stripped-libc output libc kernel-headers)
"Copy to OUTPUT the subset of LIBC and KERNEL-HEADERS that is needed
when producing a bootstrap libc."
@@ -43,25 +92,10 @@ when producing a bootstrap libc."
(string-append incdir "/mach"))
#t))
- (define (copy-linux-headers output kernel-headers)
+ (define (copy-libc+linux-headers output kernel-headers)
(let* ((incdir (string-append output "/include")))
(copy-recursively (string-append libc "/include") incdir)
-
- ;; Copy some of the Linux-Libre headers that glibc headers
- ;; refer to.
- (mkdir (string-append incdir "/linux"))
- (for-each (lambda (file)
- (install-file (string-append kernel-headers "/include/linux/" file)
- (string-append incdir "/linux")))
- '("limits.h" "errno.h" "socket.h" "kernel.h"
- "sysctl.h" "param.h" "ioctl.h" "types.h"
- "posix_types.h" "stddef.h" "falloc.h"))
-
- (copy-recursively (string-append kernel-headers "/include/asm")
- (string-append incdir "/asm"))
- (copy-recursively (string-append kernel-headers "/include/asm-generic")
- (string-append incdir "/asm-generic"))
- #t))
+ (copy-linux-headers output kernel-headers)))
(define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\
util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\
@@ -80,6 +114,6 @@ _nonshared\\.a)$")
(if (directory-exists? (string-append kernel-headers "/include/mach"))
(copy-mach-headers output kernel-headers)
- (copy-linux-headers output kernel-headers)))
+ (copy-libc+linux-headers output kernel-headers)))
diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm
index d0975fcab0..8043a84abb 100644
--- a/guix/build/meson-build-system.scm
+++ b/guix/build/meson-build-system.scm
@@ -108,6 +108,7 @@ for example libraries only needed for the tests."
;; from the gnu-build-system. If the glib-or-gtk? key is #f (the default)
;; then the extra phases will be removed again in (guix build-system meson).
(modify-phases glib-or-gtk:%standard-phases
+ (delete 'bootstrap)
(replace 'configure configure)
(replace 'build build)
(replace 'check check)
diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm
index 5bb0ba49d5..09bd8465c8 100644
--- a/guix/build/python-build-system.scm
+++ b/guix/build/python-build-system.scm
@@ -1,10 +1,11 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,6 +32,7 @@
#:export (%standard-phases
add-installed-pythonpath
site-packages
+ python-version
python-build))
;; Commentary:
@@ -146,7 +148,7 @@
(format #t "test suite not run~%"))
#t)
-(define (get-python-version python)
+(define (python-version python)
(let* ((version (last (string-split python #\-)))
(components (string-split version #\.))
(major+minor (take components 2)))
@@ -157,7 +159,7 @@
(let* ((out (assoc-ref outputs "out"))
(python (assoc-ref inputs "python")))
(string-append out "/lib/python"
- (get-python-version python)
+ (python-version python)
"/site-packages/")))
(define (add-installed-pythonpath inputs outputs)
@@ -186,11 +188,9 @@ when running checks after installing the package."
(define* (wrap #:key inputs outputs #:allow-other-keys)
(define (list-of-files dir)
- (map (cut string-append dir "/" <>)
- (or (scandir dir (lambda (f)
- (let ((s (stat (string-append dir "/" f))))
- (eq? 'regular (stat:type s)))))
- '())))
+ (find-files dir (lambda (file stat)
+ (and (eq? 'regular (stat:type stat))
+ (not (wrapper? file))))))
(define bindirs
(append-map (match-lambda
@@ -203,7 +203,7 @@ when running checks after installing the package."
(python (assoc-ref inputs "python"))
(var `("PYTHONPATH" prefix
,(cons (string-append out "/lib/python"
- (get-python-version python)
+ (python-version python)
"/site-packages")
(search-path-as-string->list
(or (getenv "PYTHONPATH") ""))))))
@@ -223,7 +223,7 @@ installed with setuptools."
(let* ((out (assoc-ref outputs "out"))
(python (assoc-ref inputs "python"))
(site-packages (string-append out "/lib/python"
- (get-python-version python)
+ (python-version python)
"/site-packages"))
(easy-install-pth (string-append site-packages "/easy-install.pth"))
(new-pth (string-append site-packages "/" name ".pth")))
@@ -251,16 +251,21 @@ installed with setuptools."
#t)
(define %standard-phases
- ;; 'configure' phase is not needed.
+ ;; The build phase only builds C extensions and copies the Python sources,
+ ;; while the install phase byte-compiles and copies them to the prefix
+ ;; directory. The tests are run after the install phase because otherwise
+ ;; the cached .pyc generated during the tests execution seem to interfere
+ ;; with the byte compilation of the install phase.
(modify-phases gnu:%standard-phases
(add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980)
(add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism
enable-bytecode-determinism)
(delete 'bootstrap)
- (delete 'configure)
- (replace 'install install)
- (replace 'check check)
+ (delete 'configure) ;not needed
(replace 'build build)
+ (delete 'check) ;moved after the install phase
+ (replace 'install install)
+ (add-after 'install 'check check)
(add-after 'install 'wrap wrap)
(add-before 'strip 'rename-pth-file rename-pth-file)))
diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm
index 63c94765f7..c957a61115 100644
--- a/guix/build/ruby-build-system.scm
+++ b/guix/build/ruby-build-system.scm
@@ -128,7 +128,7 @@ is #f."
(define* (install #:key inputs outputs (gem-flags '())
#:allow-other-keys)
"Install the gem archive SOURCE to the output store item. Additional
-GEM-FLAGS are passed to the 'gem' invokation, if present."
+GEM-FLAGS are passed to the 'gem' invocation, if present."
(let* ((ruby-version
(match:substring (string-match "ruby-(.*)\\.[0-9]$"
(assoc-ref inputs "ruby"))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 3c84d3893f..bbf2531c79 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -68,6 +68,7 @@
statfs
free-disk-space
device-in-use?
+ add-to-entropy-count
processes
mkdtemp!
@@ -396,17 +397,11 @@ the returned procedure is called."
((_ (proc args ...) body ...)
(define-as-needed proc (lambda* (args ...) body ...)))
((_ variable value)
- (begin
- (when (module-defined? the-scm-module 'variable)
- (re-export variable))
-
- (define variable
- (if (module-defined? the-scm-module 'variable)
- (module-ref the-scm-module 'variable)
- value))
-
- (unless (module-defined? the-scm-module 'variable)
- (export variable))))))
+ (if (module-defined? the-scm-module 'variable)
+ (module-re-export! (current-module) '(variable))
+ (begin
+ (module-define! (current-module) 'variable value)
+ (module-export! (current-module) '(variable)))))))
;;;
@@ -714,6 +709,33 @@ backend device."
;;;
+;;; Random.
+;;;
+
+;; From <uapi/linux/random.h>.
+(define RNDADDTOENTCNT #x40045201)
+
+(define (add-to-entropy-count port-or-fd n)
+ "Add N to the kernel's entropy count (the value that can be read from
+/proc/sys/kernel/random/entropy_avail). PORT-OR-FD must correspond to
+/dev/urandom or /dev/random. Raise to 'system-error with EPERM when the
+caller lacks root privileges."
+ (let ((fd (if (port? port-or-fd)
+ (fileno port-or-fd)
+ port-or-fd))
+ (box (make-bytevector (sizeof int))))
+ (bytevector-sint-set! box 0 n (native-endianness)
+ (sizeof int))
+ (let-values (((ret err)
+ (%ioctl fd RNDADDTOENTCNT
+ (bytevector->pointer box))))
+ (unless (zero? err)
+ (throw 'system-error "add-to-entropy-count" "~A"
+ (list (strerror err))
+ (list err))))))
+
+
+;;;
;;; Containers.
;;;
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 5fe3286843..b8be73ead4 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -1,8 +1,10 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -87,7 +89,13 @@
patch-/usr/bin/file
fold-port-matches
remove-store-references
+ wrapper?
wrap-program
+ wrap-script
+
+ wrap-error?
+ wrap-error-program
+ wrap-error-type
invoke
invoke-error?
@@ -96,10 +104,33 @@
invoke-error-exit-status
invoke-error-term-signal
invoke-error-stop-signal
+ report-invoke-error
+
+ invoke/quiet
locale-category->string))
+
+;;;
+;;; Guile 2.0 compatibility later.
+;;;
+;; The bootstrap Guile is Guile 2.0, so provide a compatibility layer.
+(cond-expand
+ ((and guile-2 (not guile-2.2))
+ (define (setvbuf port mode . rest)
+ (apply (@ (guile) setvbuf) port
+ (match mode
+ ('line _IOLBF)
+ ('block _IOFBF)
+ ('none _IONBF)
+ (_ mode)) ;an _IO* integer
+ rest))
+
+ (module-replace! (current-module) '(setvbuf)))
+ (else #f))
+
+
;;;
;;; Directories.
;;;
@@ -600,6 +631,11 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and
((_ phases (add-after old-phase-name new-phase-name new-phase))
(alist-cons-after old-phase-name new-phase-name new-phase phases))))
+
+;;;
+;;; Program invocation.
+;;;
+
(define-condition-type &invoke-error &error
invoke-error?
(program invoke-error-program)
@@ -621,6 +657,68 @@ if the exit code is non-zero; otherwise return #t."
(stop-signal (status:stop-sig code))))))
#t))
+(define* (report-invoke-error c #:optional (port (current-error-port)))
+ "Report to PORT about C, an '&invoke-error' condition, in a human-friendly
+way."
+ (format port "command~{ ~s~} failed with ~:[signal~;status~] ~a~%"
+ (cons (invoke-error-program c)
+ (invoke-error-arguments c))
+ (invoke-error-exit-status c)
+ (or (invoke-error-exit-status c)
+ (invoke-error-term-signal c)
+ (invoke-error-stop-signal c))))
+
+(define (open-pipe-with-stderr program . args)
+ "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
+both its standard output and standard error to the pipe. Return two value:
+the pipe to read PROGRAM's data from, and the PID of the child process running
+PROGRAM."
+ ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
+ ;; we need to roll our own.
+ (match (pipe)
+ ((input . output)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port input)
+ (dup2 (fileno output) 1)
+ (dup2 (fileno output) 2)
+ (apply execlp program program args))
+ (lambda ()
+ (primitive-exit 127))))
+ (pid
+ (close-port output)
+ (values input pid))))))
+
+(define (invoke/quiet program . args)
+ "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
+error. If PROGRAM succeeds, print nothing and return the unspecified value;
+otherwise, raise a '&message' error condition that includes the status code
+and the output of PROGRAM."
+ (let-values (((pipe pid)
+ (apply open-pipe-with-stderr program args)))
+ (let loop ((lines '()))
+ (match (read-line pipe)
+ ((? eof-object?)
+ (close-port pipe)
+ (match (waitpid pid)
+ ((_ . status)
+ (unless (zero? status)
+ (let-syntax ((G_ (syntax-rules () ;for xgettext
+ ((_ str) str))))
+ (raise (condition
+ (&message
+ (message (format #f (G_ "'~a~{ ~a~}' exited \
+with status ~a; output follows:~%~%~{ ~a~%~}")
+ program args
+ (or (status:exit-val status)
+ status)
+ (reverse lines)))))))))))
+ (line
+ (loop (cons line lines)))))))
+
;;;
;;; Text substitution (aka. sed).
@@ -987,8 +1085,8 @@ known as `nuke-refs' in Nixpkgs."
;; We cannot use `regexp-exec' here because it cannot deal with
;; strings containing NUL characters.
(format #t "removing store references from `~a'...~%" file)
- (setvbuf in _IOFBF 65536)
- (setvbuf out _IOFBF 65536)
+ (setvbuf in 'block 65536)
+ (setvbuf out 'block 65536)
(fold-port-matches (lambda (match result)
(put-bytevector out (string->utf8 store))
(put-u8 out (char->integer #\/))
@@ -1003,6 +1101,18 @@ known as `nuke-refs' in Nixpkgs."
(put-u8 out (char->integer char))
result))))))
+(define-condition-type &wrap-error &error
+ wrap-error?
+ (program wrap-error-program)
+ (type wrap-error-type))
+
+(define (wrapper? prog)
+ "Return #t if PROG is a wrapper as produced by 'wrap-program'."
+ (and (file-exists? prog)
+ (let ((base (basename prog)))
+ (and (string-prefix? "." base)
+ (string-suffix? "-real" base)))))
+
(define* (wrap-program prog #:rest vars)
"Make a wrapper for PROG. VARS should look like this:
@@ -1100,6 +1210,120 @@ with definitions for VARS."
(chmod prog-tmp #o755)
(rename-file prog-tmp prog))))
+(define wrap-script
+ (let ((interpreter-regex
+ (make-regexp
+ (string-append "^#! ?(/[^ ]+/bin/("
+ (string-join '("python[^ ]*"
+ "Rscript"
+ "perl"
+ "ruby"
+ "bash"
+ "sh") "|")
+ "))( ?.*)")))
+ (coding-line-regex
+ (make-regexp
+ ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)")))
+ (lambda* (prog #:key (guile (which "guile")) #:rest vars)
+ "Wrap the script PROG such that VARS are set first. The format of VARS
+is the same as in the WRAP-PROGRAM procedure. This procedure differs from
+WRAP-PROGRAM in that it does not create a separate shell script. Instead,
+PROG is modified directly by prepending a Guile script, which is interpreted
+as a comment in the script's language.
+
+Special encoding comments as supported by Python are recreated on the second
+line.
+
+Note that this procedure can only be used once per file as Guile scripts are
+not supported."
+ (define update-env
+ (match-lambda
+ ((var sep '= rest)
+ `(setenv ,var ,(string-join rest sep)))
+ ((var sep 'prefix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append ,(string-join rest sep)
+ ,sep current)
+ ,(string-join rest sep)))))
+ ((var sep 'suffix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append current ,sep
+ ,(string-join rest sep))
+ ,(string-join rest sep)))))
+ ((var '= rest)
+ `(setenv ,var ,(string-join rest ":")))
+ ((var 'prefix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append ,(string-join rest ":")
+ ":" current)
+ ,(string-join rest ":")))))
+ ((var 'suffix rest)
+ `(let ((current (getenv ,var)))
+ (setenv ,var (if current
+ (string-append current ":"
+ ,(string-join rest ":"))
+ ,(string-join rest ":")))))))
+ (let-values (((interpreter args coding-line)
+ (call-with-ascii-input-file prog
+ (lambda (p)
+ (let ((first-match
+ (false-if-exception
+ (regexp-exec interpreter-regex (read-line p)))))
+ (values (and first-match (match:substring first-match 1))
+ (and first-match (match:substring first-match 3))
+ (false-if-exception
+ (and=> (regexp-exec coding-line-regex (read-line p))
+ (lambda (m) (match:substring m 0))))))))))
+ (if interpreter
+ (let* ((header (format #f "\
+#!~a --no-auto-compile
+#!#; ~a
+#\\-~s
+#\\-~s
+"
+ guile
+ (or coding-line "Guix wrapper")
+ (cons 'begin (map update-env
+ (match vars
+ ((#:guile _ . vars) vars)
+ (_ vars))))
+ `(let ((cl (command-line)))
+ (apply execl ,interpreter
+ (car cl)
+ (cons (car cl)
+ (append
+ ',(string-split args #\space)
+ cl))))))
+ (template (string-append prog ".XXXXXX"))
+ (out (mkstemp! template))
+ (st (stat prog))
+ (mode (stat:mode st)))
+ (with-throw-handler #t
+ (lambda ()
+ (call-with-ascii-input-file prog
+ (lambda (p)
+ (format out header)
+ (dump-port p out)
+ (close out)
+ (chmod template mode)
+ (rename-file template prog)
+ (set-file-time prog st))))
+ (lambda (key . args)
+ (format (current-error-port)
+ "wrap-script: ~a: error: ~a ~s~%"
+ prog key args)
+ (false-if-exception (delete-file template))
+ (raise (condition
+ (&wrap-error (program prog)
+ (type key))))
+ #f)))
+ (raise (condition
+ (&wrap-error (program prog)
+ (type 'no-interpreter-found)))))))))
+
;;;
;;; Locales.
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index d30833c5d7..010e0decff 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -75,6 +75,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
#:env-vars
`(("bzr url" . ,(bzr-reference-url ref))
("bzr reference" . ,(bzr-reference-revision ref)))
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:local-build? #t ;don't offload repo branching
#:hash-algo hash-algo
diff --git a/guix/channels.scm b/guix/channels.scm
index 415246cbd1..2c28dccbcb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -19,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix channels)
+ #:use-module (git)
#:use-module (guix git)
#:use-module (guix records)
#:use-module (guix gexp)
@@ -26,9 +27,11 @@
#:use-module (guix discovery)
#:use-module (guix monads)
#:use-module (guix profiles)
+ #:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix combinators)
#:use-module (guix diagnostics)
+ #:use-module (guix sets)
#:use-module (guix store)
#:use-module (guix i18n)
#:use-module ((guix utils)
@@ -38,12 +41,14 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:autoload (guix self) (whole-package make-config.scm)
#:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
+ #:use-module ((ice-9 rdelim) #:select (read-string))
#:export (channel
channel?
channel-name
@@ -65,7 +70,17 @@
latest-channel-derivation
channel-instances->manifest
%channel-profile-hooks
- channel-instances->derivation))
+ channel-instances->derivation
+
+ profile-channels
+
+ channel-news-entry?
+ channel-news-entry-commit
+ channel-news-entry-tag
+ channel-news-entry-title
+ channel-news-entry-body
+
+ channel-news-for-commit))
;;; Commentary:
;;;
@@ -108,10 +123,11 @@
(checkout channel-instance-checkout))
(define-record-type <channel-metadata>
- (channel-metadata directory dependencies)
+ (channel-metadata directory dependencies news-file)
channel-metadata?
(directory channel-metadata-directory) ;string with leading slash
- (dependencies channel-metadata-dependencies)) ;list of <channel>
+ (dependencies channel-metadata-dependencies) ;list of <channel>
+ (news-file channel-metadata-news-file)) ;string | #f
(define (channel-reference channel)
"Return the \"reference\" for CHANNEL, an sexp suitable for
@@ -127,12 +143,13 @@ if valid metadata could not be read from PORT."
(match (read port)
(('channel ('version 0) properties ...)
(let ((directory (and=> (assoc-ref properties 'directory) first))
- (dependencies (or (assoc-ref properties 'dependencies) '())))
+ (dependencies (or (assoc-ref properties 'dependencies) '()))
+ (news-file (and=> (assoc-ref properties 'news-file) first)))
(channel-metadata
- (cond ((not directory) "/")
+ (cond ((not directory) "/") ;directory
((string-prefix? "/" directory) directory)
(else (string-append "/" directory)))
- (map (lambda (item)
+ (map (lambda (item) ;dependencies
(let ((get (lambda* (key #:optional default)
(or (and=> (assoc-ref item key) first) default))))
(and-let* ((name (get 'name))
@@ -143,7 +160,8 @@ if valid metadata could not be read from PORT."
(branch branch)
(url url)
(commit (get 'commit))))))
- dependencies))))
+ dependencies)
+ news-file))) ;news-file
((and ('channel ('version version) _ ...) sexp)
(raise (condition
(&message (message "unsupported '.guix-channel' version"))
@@ -167,7 +185,7 @@ doesn't exist."
read-channel-metadata))
(lambda args
(if (= ENOENT (system-error-errno args))
- (channel-metadata "/" '())
+ (channel-metadata "/" '() #f)
(apply throw args)))))
(define (channel-instance-metadata instance)
@@ -290,6 +308,46 @@ to '%package-module-path'."
(gexp->derivation-in-inferior name build core)))
+(define (syscalls-reexports-local-variables? source)
+ "Return true if (guix build syscalls) contains the bug described at
+<https://bugs.gnu.org/36723>."
+ (catch 'system-error
+ (lambda ()
+ (define content
+ (call-with-input-file (string-append source
+ "/guix/build/syscalls.scm")
+ read-string))
+
+ ;; The faulty code would use the 're-export' macro, causing the
+ ;; 'AT_SYMLINK_NOFOLLOW' local variable to be re-exported when using
+ ;; Guile > 2.2.4.
+ (string-contains content "(re-export variable)"))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ #f
+ (apply throw args)))))
+
+(define (guile-2.2.4)
+ (module-ref (resolve-interface '(gnu packages guile))
+ 'guile-2.2.4))
+
+(define %quirks
+ ;; List of predicate/package pairs. This allows us provide information
+ ;; about specific Guile versions that old Guix revisions might need to use
+ ;; just to be able to build and run the trampoline in %SELF-BUILD-FILE. See
+ ;; <https://bugs.gnu.org/37506>
+ `((,syscalls-reexports-local-variables? . ,guile-2.2.4)))
+
+(define* (guile-for-source source #:optional (quirks %quirks))
+ "Return the Guile package to use when building SOURCE or #f if the default
+'%guile-for-build' should be good enough."
+ (let loop ((quirks quirks))
+ (match quirks
+ (()
+ #f)
+ (((predicate . guile) rest ...)
+ (if (predicate source) (guile) (loop rest))))))
+
(define* (build-from-source name source
#:key core verbose? commit
(dependencies '()))
@@ -311,15 +369,19 @@ package modules under SOURCE using CORE, an instance of Guix."
;; about it.
(parameterize ((guix-warning-port
(%make-void-port "w")))
- (primitive-load script))))))
+ (primitive-load script)))))
+ (guile (guile-for-source source)))
;; BUILD must be a monadic procedure of at least one argument: the
;; source tree.
;;
;; Note: BUILD can return #f if it does not support %PULL-VERSION. In
;; the future we'll fall back to a previous version of the protocol
;; when that happens.
- (build source #:verbose? verbose? #:version commit
- #:pull-version %pull-version))
+ (mbegin %store-monad
+ (mwhen guile
+ (set-guile-for-build guile))
+ (build source #:verbose? verbose? #:version commit
+ #:pull-version %pull-version)))
;; Build a set of modules that extend Guix using the standard method.
(standard-module-derivation name source core dependencies)))
@@ -534,3 +596,142 @@ channel instances."
latest instances of CHANNELS."
(mlet %store-monad ((instances (latest-channel-instances* channels)))
(channel-instances->derivation instances)))
+
+(define (profile-channels profile)
+ "Return the list of channels corresponding to entries in PROFILE. If
+PROFILE is not a profile created by 'guix pull', return the empty list."
+ (filter-map (lambda (entry)
+ (match (assq 'source (manifest-entry-properties entry))
+ (('source ('repository ('version 0)
+ ('url url)
+ ('branch branch)
+ ('commit commit)
+ _ ...))
+ (channel (name (string->symbol
+ (manifest-entry-name entry)))
+ (url url)
+ (commit commit)))
+
+ ;; No channel information for this manifest entry.
+ ;; XXX: Pre-0.15.0 Guix did not provide that information,
+ ;; but there's not much we can do in that case.
+ (_ #f)))
+
+ ;; Show most recently installed packages last.
+ (reverse
+ (manifest-entries (profile-manifest profile)))))
+
+
+;;;
+;;; News.
+;;;
+
+;; Channel news.
+(define-record-type <channel-news>
+ (channel-news entries)
+ channel-news?
+ (entries channel-news-entries)) ;list of <channel-news-entry>
+
+;; News entry, associated with a specific commit of the channel.
+(define-record-type <channel-news-entry>
+ (channel-news-entry commit tag title body)
+ channel-news-entry?
+ (commit channel-news-entry-commit) ;hex string | #f
+ (tag channel-news-entry-tag) ;#f | string
+ (title channel-news-entry-title) ;list of language tag/string pairs
+ (body channel-news-entry-body)) ;list of language tag/string pairs
+
+(define (sexp->channel-news-entry entry)
+ "Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
+ (define (pair language message)
+ (cons (symbol->string language) message))
+
+ (match entry
+ (('entry ((and (or 'commit 'tag) type) commit-or-tag)
+ ('title ((? symbol? title-tags) (? string? titles)) ...)
+ ('body ((? symbol? body-tags) (? string? bodies)) ...)
+ _ ...)
+ (channel-news-entry (and (eq? type 'commit) commit-or-tag)
+ (and (eq? type 'tag) commit-or-tag)
+ (map pair title-tags titles)
+ (map pair body-tags bodies)))
+ (_
+ (raise (condition
+ (&message (message "invalid channel news entry"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties entry)))))))))
+
+(define (read-channel-news port)
+ "Read a channel news feed from PORT and return it as a <channel-news>
+record."
+ (match (false-if-exception (read port))
+ (('channel-news ('version 0) entries ...)
+ (channel-news (map sexp->channel-news-entry entries)))
+ (('channel-news ('version version) _ ...)
+ ;; This is an unsupported version from the future. There's nothing wrong
+ ;; with that (the user may simply need to upgrade the 'guix' channel to
+ ;; be able to read it), so silently ignore it.
+ (channel-news '()))
+ (#f
+ (raise (condition
+ (&message (message "syntactically invalid channel news file")))))
+ (sexp
+ (raise (condition
+ (&message (message "invalid channel news file"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties sexp)))))))))
+
+(define (resolve-channel-news-entry-tag repository entry)
+ "If ENTRY has its 'commit' field set, return ENTRY. Otherwise, lookup
+ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to
+the field its 'tag' refers to. A 'git-error' exception is raised if the tag
+cannot be found."
+ (if (channel-news-entry-commit entry)
+ entry
+ (let* ((tag (channel-news-entry-tag entry))
+ (reference (string-append "refs/tags/" tag))
+ (oid (reference-name->oid repository reference)))
+ (channel-news-entry (oid->string oid) tag
+ (channel-news-entry-title entry)
+ (channel-news-entry-body entry)))))
+
+(define* (channel-news-for-commit channel new #:optional old)
+ "Return a list of <channel-news-entry> for CHANNEL between commits OLD and
+NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL."
+ (catch 'git-error
+ (lambda ()
+ (let* ((checkout (update-cached-checkout (channel-url channel)
+ #:ref `(commit . ,new)))
+ (metadata (read-channel-metadata-from-source checkout))
+ (news-file (channel-metadata-news-file metadata))
+ (news-file (and news-file
+ (string-append checkout "/" news-file))))
+ (if (and news-file (file-exists? news-file))
+ (with-repository checkout repository
+ (let* ((news (call-with-input-file news-file
+ read-channel-news))
+ (entries (map (lambda (entry)
+ (resolve-channel-news-entry-tag repository
+ entry))
+ (channel-news-entries news))))
+ (if old
+ (let* ((new (commit-lookup repository (string->oid new)))
+ (old (commit-lookup repository (string->oid old)))
+ (commits (list->set
+ (map (compose oid->string commit-id)
+ (commit-difference new old)))))
+ (filter (lambda (entry)
+ (set-contains? commits
+ (channel-news-entry-commit entry)))
+ entries))
+ entries)))
+ '())))
+ (lambda (key error . rest)
+ ;; If commit NEW or commit OLD cannot be found, then something must be
+ ;; wrong (for example, the history of CHANNEL was rewritten and these
+ ;; commits no longer exist upstream), so quietly return the empty list.
+ (if (= GIT_ENOTFOUND (git-error-code error))
+ '()
+ (apply throw key error rest)))))
diff --git a/guix/ci.scm b/guix/ci.scm
index 1727297dd7..9e21996023 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,9 +18,10 @@
(define-module (guix ci)
#:use-module (guix http-client)
- #:autoload (json parser) (json->scm)
+ #:use-module (guix json)
+ #:use-module (json)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
#:export (build?
build-id
build-derivation
@@ -42,7 +43,7 @@
queued-builds
latest-builds
latest-evaluations
- evaluation-for-commit))
+ evaluations-for-commit))
;;; Commentary:
;;;
@@ -51,28 +52,31 @@
;;;
;;; Code:
-(define-record-type <build>
- (make-build id derivation system status timestamp)
- build?
- (id build-id) ;integer
+(define-json-mapping <build> make-build build?
+ json->build
+ (id build-id "id") ;integer
(derivation build-derivation) ;string | #f
(system build-system) ;string
- (status build-status) ;integer
+ (status build-status "buildstatus" ) ;integer
(timestamp build-timestamp)) ;integer
-(define-record-type <checkout>
- (make-checkout commit input)
- checkout?
+(define-json-mapping <checkout> make-checkout checkout?
+ json->checkout
(commit checkout-commit) ;string (SHA1)
(input checkout-input)) ;string (name)
-(define-record-type <evaluation>
- (make-evaluation id spec complete? checkouts)
- evaluation?
+(define-json-mapping <evaluation> make-evaluation evaluation?
+ json->evaluation
(id evaluation-id) ;integer
(spec evaluation-spec) ;string
- (complete? evaluation-complete?) ;Boolean
- (checkouts evaluation-checkouts)) ;<checkout>*
+ (complete? evaluation-complete? "in-progress"
+ (match-lambda
+ (0 #t)
+ (_ #f))) ;Boolean
+ (checkouts evaluation-checkouts "checkouts" ;<checkout>*
+ (lambda (checkouts)
+ (map json->checkout
+ (vector->list checkouts)))))
(define %query-limit
;; Max number of builds requested in queries.
@@ -84,18 +88,11 @@
(close-port port)
json))
-(define (json->build json)
- (make-build (hash-ref json "id")
- (hash-ref json "derivation")
- (hash-ref json "system")
- (hash-ref json "buildstatus")
- (hash-ref json "timestamp")))
-
(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)))))
- (map json->build queue)))
+ (map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit)
#:key evaluation system)
@@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
(option "system" system)))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
- (map json->build latest)))
-
-(define (json->checkout json)
- (make-checkout (hash-ref json "commit")
- (hash-ref json "input")))
-
-(define (json->evaluation json)
- (make-evaluation (hash-ref json "id")
- (hash-ref json "specification")
- (case (hash-ref json "in-progress")
- ((0) #t)
- (else #f))
- (map json->checkout (hash-ref json "checkouts"))))
+ (map json->build (vector->list latest))))
(define* (latest-evaluations url #:optional (limit %query-limit))
"Return the latest evaluations performed by the CI server at URL."
(map json->evaluation
- (json->scm
- (http-fetch (string-append url "/api/evaluations?nr="
- (number->string limit))))))
+ (vector->list
+ (json->scm
+ (http-fetch (string-append url "/api/evaluations?nr="
+ (number->string limit)))))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
diff --git a/guix/colors.scm b/guix/colors.scm
index 7949cf5763..b63ac37027 100644
--- a/guix/colors.scm
+++ b/guix/colors.scm
@@ -31,6 +31,8 @@
colorize-string
highlight
+ dim
+
color-rules
color-output?
isatty?*))
@@ -133,14 +135,16 @@ that subsequent output will not have any colors in effect."
(not (getenv "NO_COLOR"))
(isatty?* port)))
-(define %highlight-color (color BOLD))
+(define (coloring-procedure color)
+ "Return a procedure that applies COLOR to the given string."
+ (lambda* (str #:optional (port (current-output-port)))
+ "Return STR with extra ANSI color attributes if PORT supports it."
+ (if (color-output? port)
+ (colorize-string str color)
+ str)))
-(define* (highlight str #:optional (port (current-output-port)))
- "Return STR with extra ANSI color attributes to highlight it if PORT
-supports it."
- (if (color-output? port)
- (colorize-string str %highlight-color)
- str))
+(define highlight (coloring-procedure (color BOLD)))
+(define dim (coloring-procedure (color DARK)))
(define (colorize-matches rules)
"Return a procedure that, when passed a string, returns that string
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 8b46f8ef8c..cb42103aae 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
@@ -92,6 +92,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:hash-algo hash-algo
#:hash hash
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 92d50503ce..e1073ea39b 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -376,8 +376,8 @@ of SUBSTITUTABLES."
(substitution-oracle
store inputs #:mode mode)))
"Given INPUTS, a list of derivation-inputs, return two values: the list of
-derivation to build, and the list of substitutable items that, together,
-allows INPUTS to be realized.
+derivations to build, and the list of substitutable items that, together,
+allow INPUTS to be realized.
SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
by 'substitution-oracle'."
@@ -685,7 +685,7 @@ name of each input with that input's hash."
(make-derivation-input hash sub-drvs))))
inputs)))
(make-derivation outputs
- (sort inputs
+ (sort (delete-duplicates inputs)
(lambda (drv1 drv2)
(string<? (derivation-input-derivation drv1)
(derivation-input-derivation drv2))))
diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 380cfbb613..6c0753aef4 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -71,7 +71,12 @@ is a trivial format string."
(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
"Highlight ARG, a format string argument, if PORT supports colors."
(cond ((string? arg)
- (highlight arg port))
+ ;; If ARG contains white space, don't highlight it, on the grounds
+ ;; that it may be a complete message in its own, like those produced
+ ;; by 'guix lint.
+ (if (string-any char-set:whitespace arg)
+ arg
+ (highlight arg port)))
((symbol? arg)
(highlight (symbol->string arg) port))
(else arg)))
diff --git a/guix/docker.scm b/guix/docker.scm
index c598a073f6..97ac6d982b 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -28,11 +28,13 @@
invoke))
#:use-module (gnu build install)
#:use-module (json) ;guile-json
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module ((texinfo string-utils)
#:select (escape-special-chars))
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:export (build-docker-image))
@@ -55,22 +57,36 @@
(created . ,time)
(container_config . #nil)))
-(define (generate-tag path)
- "Generate an image tag for the given PATH."
- (match (string-split (basename path) #\-)
- ((hash name . rest) (string-append name ":" hash))))
+(define (canonicalize-repository-name name)
+ "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
+Return a version of TAG that follows these rules."
+ (define ascii-letters
+ (string->char-set "abcdefghijklmnopqrstuvwxyz"))
-(define (manifest path id)
+ (define separators
+ (string->char-set "_-."))
+
+ (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* (manifest path id #:optional (tag "guix"))
"Generate a simple image manifest."
- `#(((Config . "config.json")
- (RepoTags . #(,(generate-tag path)))
- (Layers . #(,(string-append id "/layer.tar"))))))
+ (let ((tag (canonicalize-repository-name tag)))
+ `#(((Config . "config.json")
+ (RepoTags . #(,(string-append tag ":latest")))
+ (Layers . #(,(string-append id "/layer.tar")))))))
;; According to the specifications this is required for backwards
;; compatibility. It duplicates information provided by the manifest.
-(define (repositories path id)
+(define* (repositories path id #:optional (tag "guix"))
"Generate a repositories file referencing PATH and the image ID."
- `((,(generate-tag path) . ((latest . ,id)))))
+ `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define* (config layer time arch #:key entry-point (environment '()))
@@ -99,21 +115,19 @@
'("--sort=name" "--mtime=@1"
"--owner=root:0" "--group=root:0"))
-(define symlink-source
+(define directive-file
+ ;; Return the file or directory created by a 'evaluate-populate-directive'
+ ;; directive.
(match-lambda
((source '-> target)
- (string-trim source #\/))))
-
-(define (topmost-component file)
- "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\",
-return \"a\"."
- (match (string-tokenize file (char-set-complement (char-set #\/)))
- ((first rest ...)
- first)))
+ (string-trim source #\/))
+ (('directory name _ ...)
+ (string-trim name #\/))))
(define* (build-docker-image image paths prefix
#:key
- (symlinks '())
+ (repository "guix")
+ (extra-files '())
(transformations '())
(system (utsname:machine (uname)))
database
@@ -122,7 +136,9 @@ return \"a\"."
compressor
(creation-time (current-time time-utc)))
"Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
-must be a store path that is a prefix of any store paths in PATHS.
+must be a store path that is a prefix of any store paths in PATHS. REPOSITORY
+is a descriptive name that will show up in \"REPOSITORY\" column of the output
+of \"docker images\".
When DATABASE is true, copy it to /var/guix/db in the image and create
/var/guix/gcroots and friends.
@@ -133,8 +149,9 @@ entry point in the Docker image JSON structure.
ENVIRONMENT must be a list of name/value pairs. It specifies the environment
variables that must be defined in the resulting image.
-SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
-created in the image, where each TARGET is relative to PREFIX.
+EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
+describing non-store files that must be created in the image.
+
TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
transform the PATHS. Any path in PATHS that begins with OLD will be rewritten
in the Docker image so that it begins with NEW instead. If a path is a
@@ -199,25 +216,27 @@ SRFI-19 time-utc object, as the creation time in metadata."
(with-output-to-file "json"
(lambda () (scm->json (image-description id time))))
- ;; Create SYMLINKS.
- (for-each (match-lambda
- ((source '-> target)
- (let ((source (string-trim source #\/)))
- (mkdir-p (dirname source))
- (symlink (string-append prefix "/" target)
- source))))
- symlinks)
+ ;; Create a directory for the non-store files that need to go into the
+ ;; archive.
+ (mkdir "extra")
+
+ (with-directory-excursion "extra"
+ ;; Create non-store files.
+ (for-each (cut evaluate-populate-directive <> "./")
+ extra-files)
- (when database
- ;; Initialize /var/guix, assuming PREFIX points to a profile.
- (install-database-and-gc-roots "." database prefix))
+ (when database
+ ;; Initialize /var/guix, assuming PREFIX points to a profile.
+ (install-database-and-gc-roots "." database prefix))
+
+ (apply invoke "tar" "-cf" "../layer.tar"
+ `(,@transformation-options
+ ,@%tar-determinism-options
+ ,@paths
+ ,@(scandir "."
+ (lambda (file)
+ (not (member file '("." ".."))))))))
- (apply invoke "tar" "-cf" "layer.tar"
- `(,@transformation-options
- ,@%tar-determinism-options
- ,@paths
- ,@(if database '("var") '())
- ,@(map symlink-source symlinks)))
;; It is possible for "/" to show up in the archive, especially when
;; applying transformations. For example, the transformation
;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
@@ -231,13 +250,7 @@ SRFI-19 time-utc object, as the creation time in metadata."
(lambda ()
(system* "tar" "--delete" "/" "-f" "layer.tar")))
- (for-each delete-file-recursively
- (map (compose topmost-component symlink-source)
- symlinks))
-
- ;; Delete /var/guix.
- (when database
- (delete-file-recursively "var")))
+ (delete-file-recursively "extra"))
(with-output-to-file "config.json"
(lambda ()
@@ -247,10 +260,10 @@ SRFI-19 time-utc object, as the creation time in metadata."
#:entry-point entry-point))))
(with-output-to-file "manifest.json"
(lambda ()
- (scm->json (manifest prefix id))))
+ (scm->json (manifest prefix id repository))))
(with-output-to-file "repositories"
(lambda ()
- (scm->json (repositories prefix id)))))
+ (scm->json (repositories prefix id repository)))))
(apply invoke "tar" "-cf" image "-C" directory
`(,@%tar-determinism-options
diff --git a/guix/download.scm b/guix/download.scm
index b24aaa0a86..47c8087732 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -36,6 +36,7 @@
#:use-module (srfi srfi-26)
#:export (%mirrors
url-fetch
+ url-fetch/executable
url-fetch/tarbomb
url-fetch/zipbomb
download-to-store))
@@ -419,8 +420,10 @@
(define* (built-in-download file-name url
#:key system hash-algo hash
mirrors content-addressed-mirrors
+ executable?
(guile 'unused))
- "Download FILE-NAME from URL using the built-in 'download' builder.
+ "Download FILE-NAME from URL using the built-in 'download' builder. When
+EXECUTABLE? is true, make the downloaded file executable.
This is an \"out-of-band\" download in that the returned derivation does not
explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the
@@ -432,6 +435,7 @@ download by itself using its own dependencies."
#:system system
#:hash-algo hash-algo
#:hash hash
+ #:recursive? executable?
#:sources (list mirrors content-addressed-mirrors)
;; Honor the user's proxy and locale settings.
@@ -442,7 +446,10 @@ download by itself using its own dependencies."
#:env-vars `(("url" . ,(object->string url))
("mirrors" . ,mirrors)
("content-addressed-mirrors"
- . ,content-addressed-mirrors))
+ . ,content-addressed-mirrors)
+ ,@(if executable?
+ '(("executable" . "1"))
+ '()))
;; Do not offload this derivation because we cannot be
;; sure that the remote daemon supports the 'download'
@@ -453,11 +460,13 @@ download by itself using its own dependencies."
(define* (url-fetch url hash-algo hash
#:optional name
#:key (system (%current-system))
- (guile (default-guile)))
+ (guile (default-guile))
+ executable?)
"Return a fixed-output derivation that fetches URL (a string, or a list of
strings denoting alternate URLs), which is expected to have hash HASH of type
HASH-ALGO (a symbol). By default, the file name is the base name of URL;
-optionally, NAME can specify a different file name.
+optionally, NAME can specify a different file name. When EXECUTABLE? is true,
+make the downloaded file executable.
When one of the URL starts with mirror://, then its host part is
interpreted as the name of a mirror scheme, taken from %MIRROR-FILE.
@@ -488,10 +497,21 @@ in the store."
#:system system
#:hash-algo hash-algo
#:hash hash
+ #:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
%content-addressed-mirror-file)))))
+(define* (url-fetch/executable url hash-algo hash
+ #:optional name
+ #:key (system (%current-system))
+ (guile (default-guile)))
+ "Like 'url-fetch', but make the downloaded file executable."
+ (url-fetch url hash-algo hash name
+ #:system system
+ #:guile guile
+ #:executable? #t))
+
(define* (url-fetch/tarbomb url hash-algo hash
#:optional name
#:key (system (%current-system))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 45cd5869f7..600750e846 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -663,8 +663,7 @@ names and file names suitable for the #:allowed-references argument to
(guile-for-build (%guile-for-build))
(effective-version "2.2")
- deprecation-warnings
- (pre-load-modules? #t)) ;transitional
+ deprecation-warnings)
"*Note: This API is subject to change; use at your own risk!*
Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a
@@ -731,8 +730,6 @@ derivations--e.g., code evaluated for its side effects."
#:module-path module-path
#:extensions extensions
#:guile guile
- #:pre-load-modules?
- pre-load-modules?
#:deprecation-warnings
deprecation-warnings)
(return #f))))
@@ -776,12 +773,6 @@ derivations--e.g., code evaluated for its side effects."
leaked-env-vars
local-build? (substitutable? #t)
(properties '())
-
- ;; TODO: This parameter is transitional; it's here
- ;; to avoid a full rebuild. Remove it on the next
- ;; rebuild cycle.
- (pre-load-modules? #t)
-
deprecation-warnings
(script-name (string-append name "-builder")))
"Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
@@ -865,9 +856,7 @@ The other arguments are as for 'derivation'."
#:effective-version
effective-version
#:deprecation-warnings
- deprecation-warnings
- #:pre-load-modules?
- pre-load-modules?))
+ deprecation-warnings))
(graphs (if references-graphs
(lower-reference-graphs references-graphs
@@ -1005,6 +994,15 @@ references; otherwise, return only non-native references."
(target (%current-target-system)))
"Return (monadically) the sexp corresponding to EXP for the given OUTPUT,
and in the current monad setting (system type, etc.)"
+ (define (self-quoting? x)
+ (letrec-syntax ((one-of (syntax-rules ()
+ ((_) #f)
+ ((_ pred rest ...)
+ (or (pred x)
+ (one-of rest ...))))))
+ (one-of symbol? string? keyword? pair? null? array?
+ number? boolean?)))
+
(define* (reference->sexp ref #:optional native?)
(with-monad %store-monad
(match ref
@@ -1034,8 +1032,10 @@ and in the current monad setting (system type, etc.)"
#:target target)))
;; OBJ must be either a derivation or a store file name.
(return (expand thing obj output)))))
- (($ <gexp-input> x)
+ (($ <gexp-input> (? self-quoting? x))
(return x))
+ (($ <gexp-input> x)
+ (raise (condition (&gexp-input-error (input x)))))
(x
(return x)))))
@@ -1044,19 +1044,6 @@ and in the current monad setting (system type, etc.)"
reference->sexp (gexp-references exp))))
(return (apply (gexp-proc exp) args))))
-(define (syntax-location-string s)
- "Return a string representing the source code location of S."
- (let ((props (syntax-source s)))
- (if props
- (let ((file (assoc-ref props 'filename))
- (line (and=> (assoc-ref props 'line) 1+))
- (column (assoc-ref props 'column)))
- (if file
- (simple-format #f "~a:~a:~a"
- file line column)
- (simple-format #f "~a:~a" line column)))
- "<unknown location>")))
-
(define-syntax-rule (define-syntax-parameter-once name proc)
;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME
;; does not get redefined. This works around a race condition in a
@@ -1351,11 +1338,7 @@ last one is created from the given <scheme-file> object."
(guile (%guile-for-build))
(module-path %load-path)
(extensions '())
- (deprecation-warnings #f)
-
- ;; TODO: This flag is here to prevent a full
- ;; rebuild. Remove it on the next rebuild cycle.
- (pre-load-modules? #t))
+ (deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other. When TARGET is true, cross-compile MODULES for
@@ -1395,11 +1378,8 @@ TARGET, a GNU triplet."
(let* ((base (basename entry ".scm"))
(output (string-append output "/" base ".go")))
(format #t "[~2@a/~2@a] Compiling '~a'...~%"
- (+ 1 processed
- (ungexp-splicing (if pre-load-modules?
- (gexp ((ungexp total)))
- (gexp ()))))
- (ungexp (* total (if pre-load-modules? 2 1)))
+ (+ 1 processed (ungexp total))
+ (ungexp (* total 2))
entry)
(ungexp-splicing
@@ -1423,6 +1403,26 @@ TARGET, a GNU triplet."
processed
entries)))
+ (define* (load-from-directory directory
+ #:optional (loaded 0))
+ "Load all the source files found in DIRECTORY."
+ ;; XXX: This works around <https://bugs.gnu.org/15602>.
+ (let ((entries (map (cut string-append directory "/" <>)
+ (scandir directory regular?))))
+ (fold (lambda (file loaded)
+ (if (file-is-directory? file)
+ (load-from-directory file loaded)
+ (begin
+ (format #t "[~2@a/~2@a] Loading '~a'...~%"
+ (+ 1 loaded) (ungexp (* 2 total))
+ file)
+ (save-module-excursion
+ (lambda ()
+ (primitive-load file)))
+ (+ 1 loaded))))
+ loaded
+ entries)))
+
(setvbuf (current-output-port)
(cond-expand (guile-2.2 'line) (else _IOLBF)))
@@ -1458,32 +1458,7 @@ TARGET, a GNU triplet."
(mkdir (ungexp output))
(chdir (ungexp modules))
- (ungexp-splicing
- (if pre-load-modules?
- (gexp ((define* (load-from-directory directory
- #:optional (loaded 0))
- "Load all the source files found in DIRECTORY."
- ;; XXX: This works around <https://bugs.gnu.org/15602>.
- (let ((entries (map (cut string-append directory "/" <>)
- (scandir directory regular?))))
- (fold (lambda (file loaded)
- (if (file-is-directory? file)
- (load-from-directory file loaded)
- (begin
- (format #t "[~2@a/~2@a] Loading '~a'...~%"
- (+ 1 loaded)
- (ungexp (* 2 total))
- file)
- (save-module-excursion
- (lambda ()
- (primitive-load file)))
- (+ 1 loaded))))
- loaded
- entries)))
-
- (load-from-directory ".")))
- (gexp ())))
-
+ (load-from-directory ".")
(process-directory "." (ungexp output) 0))))
;; TODO: Pass MODULES as an environment variable.
@@ -1529,24 +1504,37 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty."
#:module-path path
#:system system
#:target target)))
- (return (gexp (eval-when (expand load eval)
- (set! %load-path
- (cons (ungexp modules)
- (append (map (lambda (extension)
- (string-append extension
- "/share/guile/site/"
- (effective-version)))
- '((ungexp-native-splicing extensions)))
- %load-path)))
- (set! %load-compiled-path
- (cons (ungexp compiled)
- (append (map (lambda (extension)
- (string-append extension
- "/lib/guile/"
- (effective-version)
- "/site-ccache"))
- '((ungexp-native-splicing extensions)))
- %load-compiled-path)))))))))
+ (return
+ (gexp (eval-when (expand load eval)
+ ;; Augment the load paths and delete duplicates. Do that
+ ;; without loading (srfi srfi-1) or anything.
+ (let ((extensions '((ungexp-native-splicing extensions)))
+ (prepend (lambda (items lst)
+ ;; This is O(N²) but N is typically small.
+ (let loop ((items items)
+ (lst lst))
+ (if (null? items)
+ lst
+ (loop (cdr items)
+ (cons (car items)
+ (delete (car items) lst))))))))
+ (set! %load-path
+ (prepend (cons (ungexp modules)
+ (map (lambda (extension)
+ (string-append extension
+ "/share/guile/site/"
+ (effective-version)))
+ extensions))
+ %load-path))
+ (set! %load-compiled-path
+ (prepend (cons (ungexp compiled)
+ (map (lambda (extension)
+ (string-append extension
+ "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ extensions))
+ %load-compiled-path)))))))))
(define* (gexp->script name exp
#:key (guile (default-guile))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 8f84681d46..1eae035fc4 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -139,8 +139,11 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
;; As a last resort, attempt to download from Software Heritage.
;; XXX: Currently recursive checkouts are not supported.
(and (not recursive?)
- (swh-download (getenv "git url") (getenv "git commit")
- #$output)))))))
+ (begin
+ (format (current-error-port)
+ "Trying to download from Software Heritage...~%")
+ (swh-download (getenv "git url") (getenv "git commit")
+ #$output))))))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "git-checkout") build
@@ -154,6 +157,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
("git commit" . ,(git-reference-commit ref))
("git recursive?" . ,(object->string
(git-reference-recursive? ref))))
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:local-build? #t ;don't offload repo cloning
diff --git a/guix/git.scm b/guix/git.scm
index de98fed40c..d7dddde3a7 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -28,6 +28,7 @@
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix gexp)
+ #:use-module (guix sets)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@@ -37,8 +38,10 @@
#:export (%repository-cache-directory
honor-system-x509-certificates!
+ with-repository
update-cached-checkout
latest-repository-commit
+ commit-difference
git-checkout
git-checkout?
@@ -220,6 +223,21 @@ dynamic extent of EXP."
(G_ "Support for submodules is missing; \
please upgrade Guile-Git.~%"))))
+(define (reference-available? repository ref)
+ "Return true if REF, a reference such as '(commit . \"cabba9e\"), is
+definitely available in REPOSITORY, false otherwise."
+ (match ref
+ (('commit . commit)
+ (catch 'git-error
+ (lambda ()
+ (->bool (commit-lookup repository (string->oid commit))))
+ (lambda (key error . rest)
+ (if (= GIT_ENOTFOUND (git-error-code error))
+ #f
+ (apply throw key error rest)))))
+ (_
+ #f)))
+
(define* (update-cached-checkout url
#:key
(ref '(branch . "master"))
@@ -254,7 +272,8 @@ When RECURSIVE? is true, check out submodules as well, if any."
(repository-open cache-directory)
(clone* url cache-directory))))
;; Only fetch remote if it has not been cloned just before.
- (when cache-exists?
+ (when (and cache-exists?
+ (not (reference-available? repository ref)))
(remote-fetch (remote-lookup repository "origin")))
(when recursive?
(update-submodules repository #:log-port log-port))
@@ -325,6 +344,43 @@ Log progress and checkout info to LOG-PORT."
;;;
+;;; Commit difference.
+;;;
+
+(define (commit-closure commit)
+ "Return the closure of COMMIT as a set."
+ (let loop ((commits (list commit))
+ (visited (setq)))
+ (match commits
+ (()
+ visited)
+ ((head . tail)
+ (if (set-contains? visited head)
+ (loop tail visited)
+ (loop (append (commit-parents head) tail)
+ (set-insert head visited)))))))
+
+(define (commit-difference new old)
+ "Return the list of commits between NEW and OLD, where OLD is assumed to be
+an ancestor of NEW.
+
+Essentially, this computes the set difference between the closure of NEW and
+that of OLD."
+ (let loop ((commits (list new))
+ (result '())
+ (visited (commit-closure old)))
+ (match commits
+ (()
+ (reverse result))
+ ((head . tail)
+ (if (set-contains? visited head)
+ (loop tail result visited)
+ (loop (append (commit-parents head) tail)
+ (cons head result)
+ (set-insert head visited)))))))
+
+
+;;;
;;; Checkouts.
;;;
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index d63d44f629..ef067704ad 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -62,7 +62,6 @@
%gnu-updater
%gnu-ftp-updater
- %kde-updater
%xorg-updater
%kernel.org-updater))
@@ -230,12 +229,6 @@ network to check in GNU's database."
(or (assoc-ref (package-properties package) 'ftp-directory)
(string-append "/gnu/" name)))))
-(define (sans-extension tarball)
- "Return TARBALL without its .tar.* or .zip extension."
- (let ((end (or (string-contains tarball ".tar")
- (string-contains tarball ".zip"))))
- (substring tarball 0 end)))
-
(define %tarball-rx
;; The .zip extensions is notably used for freefont-ttf.
;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz".
@@ -261,14 +254,15 @@ true."
(string-append project
"-src")))))))
(not (regexp-exec %alpha-tarball-rx file))
- (let ((s (sans-extension file)))
+ (let ((s (tarball-sans-extension file)))
(regexp-exec %package-name-rx s))))
(define (tarball->version tarball)
"Return the version TARBALL corresponds to. TARBALL is a file name like
\"coreutils-8.23.tar.xz\"."
(let-values (((name version)
- (gnu-package-name->name+version (sans-extension tarball))))
+ (gnu-package-name->name+version
+ (tarball-sans-extension tarball))))
version))
(define* (releases project
@@ -492,8 +486,9 @@ return the corresponding signature URL, or #f it signatures are unavailable."
(and (string=? url (basename url)) ;relative reference?
(release-file? package url)
(let-values (((name version)
- (package-name->name+version (sans-extension url)
- #\-)))
+ (package-name->name+version
+ (tarball-sans-extension url)
+ #\-)))
(upstream-source
(package name)
(version version)
@@ -565,14 +560,16 @@ list available from %GNU-FILE-LIST-URI over HTTP(S)."
(release-file? name (basename file))))
files)))
(match (sort relevant (lambda (file1 file2)
- (version>? (sans-extension (basename file1))
- (sans-extension (basename file2)))))
+ (version>? (tarball-sans-extension
+ (basename file1))
+ (tarball-sans-extension
+ (basename file2)))))
((and tarballs (reference _ ...))
(let* ((version (tarball->version reference))
(tarballs (filter (lambda (file)
- (string=? (sans-extension
+ (string=? (tarball-sans-extension
(basename file))
- (sans-extension
+ (tarball-sans-extension
(basename reference))))
tarballs)))
(upstream-source
@@ -615,16 +612,6 @@ releases are on gnu.org."
(define gnu-hosted?
(url-prefix-predicate "mirror://gnu/"))
-(define (latest-kde-release package)
- "Return the latest release of PACKAGE, the name of an KDE.org package."
- (let ((uri (string->uri (origin-uri (package-source package)))))
- (false-if-ftp-error
- (latest-ftp-release
- (package-upstream-name package)
- #:server "ftp.mirrorservice.org"
- #:directory (string-append "/sites/ftp.kde.org/pub/kde/"
- (dirname (dirname (uri-path uri))))))))
-
(define (latest-xorg-release package)
"Return the latest release of PACKAGE, the name of an X.org package."
(let ((uri (string->uri (origin-uri (package-source package)))))
@@ -672,13 +659,6 @@ releases are on gnu.org."
(pure-gnu-package? package))))
(latest latest-release*)))
-(define %kde-updater
- (upstream-updater
- (name 'kde)
- (description "Updater for KDE packages")
- (pred (url-prefix-predicate "mirror://kde/"))
- (latest latest-kde-release)))
-
(define %xorg-updater
(upstream-updater
(name 'xorg)
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 6b25b87b6b..4cdc1a780a 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
@@ -92,6 +92,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:local-build? #t ;don't offload repo cloning
#:hash-algo hash-algo
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 3240094444..e47aff2b12 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -24,6 +24,7 @@
#:use-module ((ice-9 rdelim) #:select (read-string read-line))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (ice-9 receive)
@@ -32,11 +33,13 @@
#:use-module (guix http-client)
#:use-module (gcrypt hash)
#:use-module (guix store)
+ #:use-module ((guix serialization) #:select (write-file))
#:use-module (guix base32)
#:use-module ((guix download) #:select (download-to-store))
#:use-module (guix import utils)
#:use-module ((guix build utils) #:select (find-files))
#:use-module (guix utils)
+ #:use-module (guix git)
#:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
#:use-module (guix upstream)
#:use-module (guix packages)
@@ -46,6 +49,7 @@
cran-recursive-import
%cran-updater
%bioconductor-updater
+ %bioconductor-version
cran-package?
bioconductor-package?
@@ -132,14 +136,19 @@ package definition."
;; updated together.
(define %bioconductor-version "3.9")
-(define %bioconductor-packages-list-url
+(define* (bioconductor-packages-list-url #:optional type)
(string-append "https://bioconductor.org/packages/"
- %bioconductor-version "/bioc/src/contrib/PACKAGES"))
-
-(define (bioconductor-packages-list)
+ %bioconductor-version
+ (match type
+ ('annotation "/data/annotation")
+ ('experiment "/data/experiment")
+ (_ "/bioc"))
+ "/src/contrib/PACKAGES"))
+
+(define* (bioconductor-packages-list #:optional type)
"Return the latest version of package NAME for the current bioconductor
release."
- (let ((url (string->uri %bioconductor-packages-list-url)))
+ (let ((url (string->uri (bioconductor-packages-list-url type))))
(guard (c ((http-get-error? c)
(format (current-error-port)
"error: failed to retrieve list of packages from ~s: ~a (~s)~%"
@@ -153,19 +162,33 @@ release."
(description->alist (string-join chunk "\n")))
(chunk-lines (read-lines (http-fetch/cached url)))))))
-(define (latest-bioconductor-package-version name)
+(define* (latest-bioconductor-package-version name #:optional type)
"Return the version string corresponding to the latest release of the
bioconductor package NAME, or #F if the package is unknown."
(and=> (find (lambda (meta)
(string=? (assoc-ref meta "Package") name))
- (bioconductor-packages-list))
+ (bioconductor-packages-list type))
(cut assoc-ref <> "Version")))
+;; XXX taken from (guix scripts hash)
+(define (vcs-file? file stat)
+ (case (stat:type stat)
+ ((directory)
+ (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+ ((regular)
+ ;; Git sub-modules have a '.git' file that is a regular text file.
+ (string=? (basename file) ".git"))
+ (else
+ #f)))
+
;; Little helper to download URLs only once.
(define download
(memoize
- (lambda (url)
- (with-store store (download-to-store store url)))))
+ (lambda* (url #:optional git)
+ (with-store store
+ (if git
+ (latest-repository-commit store url)
+ (download-to-store store url))))))
(define (fetch-description repository name)
"Return an alist of the contents of the DESCRIPTION file for the R package
@@ -187,8 +210,12 @@ from ~s: ~a (~s)~%"
;; Currently, the bioconductor project does not offer a way to access a
;; package's DESCRIPTION file over HTTP, so we determine the version,
;; download the source tarball, and then extract the DESCRIPTION file.
- (and-let* ((version (latest-bioconductor-package-version name))
- (url (car (bioconductor-uri name version)))
+ (and-let* ((type (or
+ (and (latest-bioconductor-package-version name) #t)
+ (and (latest-bioconductor-package-version name 'annotation) 'annotation)
+ (and (latest-bioconductor-package-version name 'experiment) 'experiment)))
+ (version (latest-bioconductor-package-version name type))
+ (url (car (bioconductor-uri name version type)))
(tarball (download url)))
(call-with-temporary-directory
(lambda (dir)
@@ -198,8 +225,23 @@ from ~s: ~a (~s)~%"
"--strip-components=1"
"-C" dir
"-f" tarball "*/DESCRIPTION"))
- (description->alist (with-input-from-file
- (string-append dir "/DESCRIPTION") read-string))))))))))
+ (and=> (description->alist (with-input-from-file
+ (string-append dir "/DESCRIPTION") read-string))
+ (lambda (meta)
+ (if (boolean? type) meta
+ (cons `(bioconductor-type . ,type) meta))))))))))
+ ((git)
+ (and (string-prefix? "http" name)
+ ;; Download the git repository at "NAME"
+ (call-with-values
+ (lambda () (download name #t))
+ (lambda (dir commit)
+ (and=> (description->alist (with-input-from-file
+ (string-append dir "/DESCRIPTION") read-string))
+ (lambda (meta)
+ (cons* `(git . ,name)
+ `(git-commit . ,commit)
+ meta)))))))))
(define (listify meta field)
"Look up FIELD in the alist META. If FIELD contains a comma-separated
@@ -244,7 +286,7 @@ empty list when the FIELD cannot be found."
(define cran-guix-name (cut guix-name "r-" <>))
-(define (needs-fortran? tarball)
+(define (tarball-needs-fortran? tarball)
"Check if the TARBALL contains Fortran source files."
(define (check pattern)
(parameterize ((current-error-port (%make-void-port "rw+"))
@@ -254,65 +296,127 @@ empty list when the FIELD cannot be found."
(check "*.f95")
(check "*.f")))
+(define (directory-needs-fortran? dir)
+ "Check if the directory DIR contains Fortran source files."
+ (match (find-files dir "\\.f(90|95)?")
+ (() #f)
+ (_ #t)))
+
+(define (needs-fortran? thing tarball?)
+ "Check if the THING contains Fortran source files."
+ (if tarball?
+ (tarball-needs-fortran? thing)
+ (directory-needs-fortran? thing)))
+
+(define (files-match-pattern? directory regexp . file-patterns)
+ "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match
+the given REGEXP."
+ (let ((pattern (make-regexp regexp)))
+ (any (lambda (file)
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ()
+ (let ((line (read-line port)))
+ (cond
+ ((eof-object? line) #f)
+ ((regexp-exec pattern line) #t)
+ (else (loop))))))))
+ (apply find-files directory file-patterns))))
+
(define (tarball-files-match-pattern? tarball regexp . file-patterns)
"Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
match the given REGEXP."
(call-with-temporary-directory
(lambda (dir)
- (let ((pattern (make-regexp regexp)))
- (parameterize ((current-error-port (%make-void-port "rw+")))
- (apply system* "tar"
- "xf" tarball "-C" dir
- `("--wildcards" ,@file-patterns)))
- (any (lambda (file)
- (call-with-input-file file
- (lambda (port)
- (let loop ()
- (let ((line (read-line port)))
- (cond
- ((eof-object? line) #f)
- ((regexp-exec pattern line) #t)
- (else (loop))))))))
- (find-files dir))))))
-
-(define (needs-zlib? tarball)
+ (parameterize ((current-error-port (%make-void-port "rw+")))
+ (apply system* "tar"
+ "xf" tarball "-C" dir
+ `("--wildcards" ,@file-patterns)))
+ (files-match-pattern? dir regexp))))
+
+(define (directory-needs-zlib? dir)
+ "Return #T if any of the Makevars files in the src directory DIR contain a
+zlib linker flag."
+ (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)"))
+
+(define (tarball-needs-zlib? tarball)
"Return #T if any of the Makevars files in the src directory of the TARBALL
contain a zlib linker flag."
(tarball-files-match-pattern?
tarball "-lz"
"*/src/Makevars*" "*/src/configure*" "*/configure*"))
-(define (needs-pkg-config? tarball)
+(define (needs-zlib? thing tarball?)
+ "Check if the THING contains files indicating a dependency on zlib."
+ (if tarball?
+ (tarball-needs-zlib? thing)
+ (directory-needs-zlib? thing)))
+
+(define (directory-needs-pkg-config? dir)
+ "Return #T if any of the Makevars files in the src directory DIR reference
+the pkg-config tool."
+ (files-match-pattern? dir "pkg-config"
+ "(Makevars.*|configure.*)"))
+
+(define (tarball-needs-pkg-config? tarball)
"Return #T if any of the Makevars files in the src directory of the TARBALL
reference the pkg-config tool."
(tarball-files-match-pattern?
tarball "pkg-config"
"*/src/Makevars*" "*/src/configure*" "*/configure*"))
+(define (needs-pkg-config? thing tarball?)
+ "Check if the THING contains files indicating a dependency on pkg-config."
+ (if tarball?
+ (tarball-needs-pkg-config? thing)
+ (directory-needs-pkg-config? thing)))
+
+;; XXX adapted from (guix scripts hash)
+(define (file-hash file select? recursive?)
+ ;; Compute the hash of FILE.
+ (if recursive?
+ (let-values (((port get-hash) (open-sha256-port)))
+ (write-file file port #:select? select?)
+ (force-output port)
+ (get-hash))
+ (call-with-input-file file port-sha256)))
+
(define (description->package repository meta)
"Return the `package' s-expression for an R package published on REPOSITORY
from the alist META, which was derived from the R package's DESCRIPTION file."
(let* ((base-url (case repository
((cran) %cran-url)
- ((bioconductor) %bioconductor-url)))
+ ((bioconductor) %bioconductor-url)
+ ((git) #f)))
(uri-helper (case repository
((cran) cran-uri)
- ((bioconductor) bioconductor-uri)))
+ ((bioconductor) bioconductor-uri)
+ ((git) #f)))
(name (assoc-ref meta "Package"))
(synopsis (assoc-ref meta "Title"))
(version (assoc-ref meta "Version"))
(license (string->license (assoc-ref meta "License")))
;; Some packages have multiple home pages. Some have none.
- (home-page (match (listify meta "URL")
- ((url rest ...) url)
- (_ (string-append base-url name))))
- (source-url (match (uri-helper name version)
- ((url rest ...) url)
- ((? string? url) url)
- (_ #f)))
- (tarball (download source-url))
+ (home-page (case repository
+ ((git) (assoc-ref meta 'git))
+ (else (match (listify meta "URL")
+ ((url rest ...) url)
+ (_ (string-append base-url name))))))
+ (source-url (case repository
+ ((git) (assoc-ref meta 'git))
+ (else
+ (match (apply uri-helper name version
+ (case repository
+ ((bioconductor)
+ (list (assoc-ref meta 'bioconductor-type)))
+ (else '())))
+ ((url rest ...) url)
+ ((? string? url) url)
+ (_ #f)))))
+ (git? (assoc-ref meta 'git))
+ (source (download source-url git?))
(sysdepends (append
- (if (needs-zlib? tarball) '("zlib") '())
+ (if (needs-zlib? source (not git?)) '("zlib") '())
(filter (lambda (name)
(not (member name invalid-packages)))
(map string-downcase (listify meta "SystemRequirements")))))
@@ -323,37 +427,67 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
(listify meta "Imports")
(listify meta "LinkingTo")
(delete "R"
- (listify meta "Depends"))))))
+ (listify meta "Depends")))))
+ (package
+ `(package
+ (name ,(cran-guix-name name))
+ (version ,(case repository
+ ((git)
+ `(git-version ,version revision commit))
+ (else version)))
+ (source (origin
+ (method ,(if git?
+ 'git-fetch
+ 'url-fetch))
+ (uri ,(case repository
+ ((git)
+ `(git-reference
+ (url ,(assoc-ref meta 'git))
+ (commit commit)))
+ (else
+ `(,(procedure-name uri-helper) ,name version
+ ,@(or (and=> (assoc-ref meta 'bioconductor-type)
+ (lambda (type)
+ (list (list 'quote type))))
+ '())))))
+ ,@(if git?
+ '((file-name (git-file-name name version)))
+ '())
+ (sha256
+ (base32
+ ,(bytevector->nix-base32-string
+ (case repository
+ ((git)
+ (file-hash source (negate vcs-file?) #t))
+ (else (file-sha256 source))))))))
+ ,@(if (not (and git?
+ (equal? (string-append "r-" name)
+ (cran-guix-name name))))
+ `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
+ '())
+ (build-system r-build-system)
+ ,@(maybe-inputs sysdepends)
+ ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
+ ,@(maybe-inputs
+ `(,@(if (needs-fortran? source (not git?))
+ '("gfortran") '())
+ ,@(if (needs-pkg-config? source (not git?))
+ '("pkg-config") '()))
+ 'native-inputs)
+ (home-page ,(if (string-null? home-page)
+ (string-append base-url name)
+ home-page))
+ (synopsis ,synopsis)
+ (description ,(beautify-description (or (assoc-ref meta "Description")
+ "")))
+ (license ,license))))
(values
- `(package
- (name ,(cran-guix-name name))
- (version ,version)
- (source (origin
- (method url-fetch)
- (uri (,(procedure-name uri-helper) ,name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string (file-sha256 tarball))))))
- ,@(if (not (equal? (string-append "r-" name)
- (cran-guix-name name)))
- `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
- '())
- (build-system r-build-system)
- ,@(maybe-inputs sysdepends)
- ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
- ,@(maybe-inputs
- `(,@(if (needs-fortran? tarball)
- '("gfortran") '())
- ,@(if (needs-pkg-config? tarball)
- '("pkg-config") '()))
- 'native-inputs)
- (home-page ,(if (string-null? home-page)
- (string-append base-url name)
- home-page))
- (synopsis ,synopsis)
- (description ,(beautify-description (or (assoc-ref meta "Description")
- "")))
- (license ,license))
+ (case repository
+ ((git)
+ `(let ((commit ,(assoc-ref meta 'git-commit))
+ (revision "1"))
+ ,package))
+ (else package))
propagate)))
(define cran->guix-package
@@ -362,12 +496,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
"Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
s-expression corresponding to that package, or #f on failure."
(let ((description (fetch-description repo package-name)))
- (if (and (not description)
- (eq? repo 'bioconductor))
- ;; Retry import from CRAN
- (cran->guix-package package-name 'cran)
- (and description
- (description->package repo description)))))))
+ (if description
+ (description->package repo description)
+ (case repo
+ ((git)
+ ;; Retry import from Bioconductor
+ (cran->guix-package package-name 'bioconductor))
+ ((bioconductor)
+ ;; Retry import from CRAN
+ (cran->guix-package package-name 'cran))
+ (else #f)))))))
(define* (cran-recursive-import package-name #:optional (repo 'cran))
(recursive-import package-name repo
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index 52c5cb1c30..8dc014d232 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -1,5 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +24,7 @@
#:use-module ((guix download) #:prefix download:)
#:use-module (gcrypt hash)
#:use-module (guix http-client)
+ #:use-module (guix json)
#:use-module (guix import json)
#:use-module (guix import utils)
#:use-module ((guix licenses) #:prefix license:)
@@ -30,55 +33,92 @@
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (ice-9 match)
- #:use-module (ice-9 pretty-print) ; recursive
+ #:use-module (ice-9 regex)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-26)
#:export (crate->guix-package
guix-package->crate-name
+ crate-recursive-import
%crate-updater))
-(define (crate-fetch crate-name callback)
- "Fetch the metadata for CRATE-NAME from crates.io and call the callback."
+
+;;;
+;;; Interface to https://crates.io/api/v1.
+;;;
- (define (crates->inputs crates)
- (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?))
+;; Crates. A crate is essentially a "package". It can have several
+;; "versions", each of which has its own set of dependencies, license,
+;; etc.--see <crate-version> below.
+(define-json-mapping <crate> make-crate crate?
+ json->crate
+ (name crate-name) ;string
+ (latest-version crate-latest-version "max_version") ;string
+ (home-page crate-home-page "homepage") ;string | #nil
+ (repository crate-repository) ;string
+ (description crate-description) ;string
+ (keywords crate-keywords ;list of strings
+ "keywords" vector->list)
+ (categories crate-categories ;list of strings
+ "categories" vector->list)
+ (versions crate-versions "actual_versions" ;list of <crate-version>
+ (lambda (vector)
+ (map json->crate-version
+ (vector->list vector))))
+ (links crate-links)) ;alist
- (define (string->license string)
- (map spdx-string->license (string-split string #\/)))
-
- (define (crate-kind-predicate kind)
- (lambda (dep) (string=? (assoc-ref dep "kind") kind)))
-
- (and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
- (crate (assoc-ref crate-json "crate"))
- (name (assoc-ref crate "name"))
- (version (assoc-ref crate "max_version"))
- (homepage (assoc-ref crate "homepage"))
- (repository (assoc-ref crate "repository"))
- (synopsis (assoc-ref crate "description"))
- (description (assoc-ref crate "description"))
- (license (or (and=> (assoc-ref crate "license")
- string->license)
- '())) ;missing license info
- (path (string-append "/" version "/dependencies"))
- (deps-json (json-fetch (string-append crate-url name path)))
- (deps (vector->list (assoc-ref deps-json "dependencies")))
- (dep-crates (filter (crate-kind-predicate "normal") deps))
- (dev-dep-crates
- (filter (lambda (dep)
- (not ((crate-kind-predicate "normal") dep))) deps))
- (cargo-inputs (crates->inputs dep-crates))
- (cargo-development-inputs (crates->inputs dev-dep-crates))
- (home-page (match homepage
- (() repository)
- (_ homepage))))
- (callback #:name name #:version version
- #:cargo-inputs cargo-inputs
- #:cargo-development-inputs cargo-development-inputs
- #:home-page home-page #:synopsis synopsis
- #:description description #:license license)))
+;; Crate version.
+(define-json-mapping <crate-version> make-crate-version crate-version?
+ json->crate-version
+ (id crate-version-id) ;integer
+ (number crate-version-number "num") ;string
+ (download-path crate-version-download-path "dl_path") ;string
+ (readme-path crate-version-readme-path "readme_path") ;string
+ (license crate-version-license "license") ;string
+ (links crate-version-links)) ;alist
+
+;; Crate dependency. Each dependency (each edge in the graph) is annotated as
+;; being a "normal" dependency or a development dependency. There also
+;; information about the minimum required version, such as "^0.0.41".
+(define-json-mapping <crate-dependency> make-crate-dependency
+ crate-dependency?
+ json->crate-dependency
+ (id crate-dependency-id "crate_id") ;string
+ (kind crate-dependency-kind "kind" ;'normal | 'dev
+ string->symbol)
+ (requirement crate-dependency-requirement "req")) ;string
+
+(define (lookup-crate name)
+ "Look up NAME on https://crates.io and return the corresopnding <crate>
+record or #f if it was not found."
+ (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/"
+ name))))
+ (and=> (and json (assoc-ref json "crate"))
+ (lambda (alist)
+ ;; The "versions" field of ALIST is simply a list of version IDs
+ ;; (integers). Here, we squeeze in the actual version
+ ;; dictionaries that are not part of ALIST but are just more
+ ;; convenient handled this way.
+ (let ((versions (or (assoc-ref json "versions") '#())))
+ (json->crate `(,@alist
+ ("actual_versions" . ,versions))))))))
+
+(define (crate-version-dependencies version)
+ "Return the list of <crate-dependency> records of VERSION, a
+<crate-version>."
+ (let* ((path (assoc-ref (crate-version-links version) "dependencies"))
+ (url (string-append (%crate-base-url) path)))
+ (match (assoc-ref (or (json-fetch url) '()) "dependencies")
+ ((? vector? vector)
+ (map json->crate-dependency (vector->list vector)))
+ (_
+ '()))))
+
+
+;;;
+;;; Converting crates to Guix packages.
+;;;
(define (maybe-cargo-inputs package-names)
(match (package-names->package-inputs package-names)
@@ -138,10 +178,65 @@ and LICENSE."
(close-port port)
pkg))
-(define (crate->guix-package crate-name)
+(define %dual-license-rx
+ ;; Dual licensing is represented by a string such as "MIT OR Apache-2.0".
+ ;; This regexp matches that.
+ (make-regexp "^(.*) OR (.*)$"))
+
+(define* (crate->guix-package crate-name #:optional version)
"Fetch the metadata for CRATE-NAME from crates.io, and return the
-`package' s-expression corresponding to that package, or #f on failure."
- (crate-fetch crate-name make-crate-sexp))
+`package' s-expression corresponding to that package, or #f on failure.
+When VERSION is specified, attempt to fetch that version; otherwise fetch the
+latest version of CRATE-NAME."
+ (define (string->license string)
+ (match (regexp-exec %dual-license-rx string)
+ (#f (list (spdx-string->license string)))
+ (m (list (spdx-string->license (match:substring m 1))
+ (spdx-string->license (match:substring m 2))))))
+
+ (define (normal-dependency? dependency)
+ (eq? (crate-dependency-kind dependency) 'normal))
+
+ (define crate
+ (lookup-crate crate-name))
+
+ (define version-number
+ (or version
+ (crate-latest-version crate)))
+
+ (define version*
+ (find (lambda (version)
+ (string=? (crate-version-number version)
+ version-number))
+ (crate-versions crate)))
+
+ (and crate version*
+ (let* ((dependencies (crate-version-dependencies version*))
+ (dep-crates (filter normal-dependency? dependencies))
+ (dev-dep-crates (remove normal-dependency? dependencies))
+ (cargo-inputs (sort (map crate-dependency-id dep-crates)
+ string-ci<?))
+ (cargo-development-inputs
+ (sort (map crate-dependency-id dev-dep-crates)
+ string-ci<?)))
+ (values
+ (make-crate-sexp #:name crate-name
+ #:version (crate-version-number version*)
+ #:cargo-inputs cargo-inputs
+ #:cargo-development-inputs cargo-development-inputs
+ #:home-page (or (crate-home-page crate)
+ (crate-repository crate))
+ #:synopsis (crate-description crate)
+ #:description (crate-description crate)
+ #:license (and=> (crate-version-license version*)
+ string->license))
+ (append cargo-inputs cargo-development-inputs)))))
+
+(define (crate-recursive-import crate-name)
+ (recursive-import crate-name #f
+ #:repo->guix-package (lambda (name repo)
+ (crate->guix-package name))
+ #:guix-name crate-name->package-name))
(define (guix-package->crate-name package)
"Return the crate name of PACKAGE."
@@ -157,6 +252,7 @@ and LICENSE."
(define (crate-name->package-name name)
(string-append "rust-" (string-join (string-split name #\_) "-")))
+
;;;
;;; Updater
;;;
@@ -175,9 +271,9 @@ and LICENSE."
(define (latest-release package)
"Return an <upstream-source> for the latest release of PACKAGE."
(let* ((crate-name (guix-package->crate-name package))
- (callback (lambda* (#:key version #:allow-other-keys) version))
- (version (crate-fetch crate-name callback))
- (url (crate-uri crate-name version)))
+ (crate (lookup-crate crate-name))
+ (version (crate-latest-version crate))
+ (url (crate-uri crate-name version)))
(upstream-source
(package (package-name package))
(version version)
diff --git a/guix/import/github.scm b/guix/import/github.scm
index fa23fa4c06..df5f6ff32f 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -49,7 +50,7 @@ false if none is recognized"
(define (updated-url url)
(if (string-prefix? "https://github.com/" url)
(let ((ext (or (find-extension url) ""))
- (name (package-name old-package))
+ (name (package-upstream-name old-package))
(version (package-version old-package))
(prefix (string-append "https://github.com/"
(github-user-slash-repository url)))
@@ -161,7 +162,7 @@ empty list."
url))
(match (json-fetch (decorate release-url) #:headers headers)
- (()
+ (#()
;; We got the empty list, presumably because the user didn't use GitHub's
;; "release" mechanism, but hopefully they did use Git tags.
(json-fetch (decorate tag-url) #:headers headers))
@@ -186,7 +187,12 @@ the package e.g. 'bedtools2'. Return #f if there is no releases"
(substring tag 0 (+ name-length 1))))
(substring tag (+ name-length 1)))
;; some tags start with a "v" e.g. "v0.25.0"
+ ;; or with the word "version" e.g. "version.2.1"
;; where some are just the version number
+ ((string-prefix? "version" tag)
+ (if (char-set-contains? char-set:digit (string-ref tag 7))
+ (substring tag 7)
+ (substring tag 8)))
((string-prefix? "v" tag)
(substring tag 1))
;; Finally, reject tags that don't start with a digit:
diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm
index 1ade63e1af..436ec88ef9 100644
--- a/guix/import/gnome.scm
+++ b/guix/import/gnome.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -46,7 +46,7 @@ source for metadata."
(package name)
(version version)
(urls (filter-map (lambda (extension)
- (match (hash-ref dictionary extension)
+ (match (assoc-ref dictionary extension)
(#f
#f)
((? string? relative-url)
@@ -86,21 +86,22 @@ not be determined."
(json (json->scm port)))
(close-port port)
(match json
- ((4 (? hash-table? releases) _ ...)
- (let* ((releases (hash-ref releases upstream-name))
- (latest (hash-fold (lambda (key value result)
- (cond ((even-minor-version? key)
- (match result
- (#f
- (cons key value))
- ((newest . _)
- (if (version>? key newest)
- (cons key value)
- result))))
- (else
- result)))
- #f
- releases)))
+ (#(4 releases _ ...)
+ (let* ((releases (assoc-ref releases upstream-name))
+ (latest (fold (match-lambda*
+ (((key . value) result)
+ (cond ((even-minor-version? key)
+ (match result
+ (#f
+ (cons key value))
+ ((newest . _)
+ (if (version>? key newest)
+ (cons key value)
+ result))))
+ (else
+ result))))
+ #f
+ releases)))
(and latest
(jsonish->upstream-source upstream-name latest))))))))
diff --git a/guix/import/kde.scm b/guix/import/kde.scm
new file mode 100644
index 0000000000..6873418d62
--- /dev/null
+++ b/guix/import/kde.scm
@@ -0,0 +1,190 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.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 import kde)
+ #:use-module (guix http-client)
+ #:use-module (guix memoization)
+ #:use-module (guix gnu-maintenance)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-11)
+ #:use-module (web uri)
+
+ #:export (%kde-updater))
+
+;;; Commentary:
+;;;
+;;; This package provides not an actual importer but simply an updater for
+;;; KDE packages. It grabs available files from the 'ls-lR.bz2' file
+;;; available on download.kde.org.
+;;;
+;;; Code:
+
+(define (tarball->version tarball)
+ "Return the version TARBALL corresponds to. TARBALL is a file name like
+\"coreutils-8.23.tar.xz\"."
+ (let-values (((name version)
+ (gnu-package-name->name+version
+ (tarball-sans-extension tarball))))
+ version))
+
+(define %kde-file-list-uri
+ ;; URI of the file list (ls -lR format) for download.kde.org.
+ (string->uri "https://download.kde.org/ls-lR.bz2"))
+
+(define (download.kde.org-files)
+ ;;"Return the list of files available at download.kde.org."
+
+ (define (ls-lR-line->filename path line)
+ ;; Remove mode, blocks, user, group, size, date, time and one space,
+ ;; then prepend PATH
+ (regexp-substitute
+ #f (string-match "^(\\S+\\s+){6}\\S+\\s" line) path 'post))
+
+ (define (canonicalize path)
+ (let* ((path (if (string-prefix? "/srv/archives/ftp/" path)
+ (string-drop path (string-length "/srv/archives/ftp"))
+ path))
+ (path (if (string-suffix? ":" path)
+ (string-drop-right path 1)
+ path))
+ (path (if (not (string-suffix? "/" path))
+ (string-append path "/")
+ path)))
+ path))
+
+ (define (write-cache input cache)
+ "Read bzipped ls-lR from INPUT, and write it as a list of file paths to
+CACHE."
+ (call-with-decompressed-port 'bzip2 input
+ (lambda (input)
+ (let loop_dirs ((files '()))
+ ;; process a new directory block
+ (let ((path (read-line input)))
+ (if
+ (or (eof-object? path) (string= path ""))
+ (write (reverse files) cache)
+ (let loop_entries ((path (canonicalize path))
+ (files files))
+ ;; process entries within the directory block
+ (let ((line (read-line input)))
+ (cond
+ ((eof-object? line)
+ (write (reverse files) cache))
+ ((string-prefix? "-" line)
+ ;; this is a file entry: prepend to FILES, then re-enter
+ ;; the loop for remaining entries
+ (loop_entries path
+ (cons (ls-lR-line->filename path line) files)
+ ))
+ ((not (string= line ""))
+ ;; this is a non-file entry: ignore it, just re-enter the
+ ;; loop for remaining entries
+ (loop_entries path files))
+ ;; empty line: directory block end, re-enter the outer
+ ;; loop for the next block
+ (#t (loop_dirs files)))))))))))
+
+ (define (cache-miss uri)
+ (format (current-error-port) "fetching ~a...~%" (uri->string uri)))
+
+ (let* ((port (http-fetch/cached %kde-file-list-uri
+ #:ttl 3600
+ #:write-cache write-cache
+ #:cache-miss cache-miss))
+ (files (read port)))
+ (close-port port)
+ files))
+
+(define (uri->kde-path-pattern uri)
+ "Build a regexp from the package's URI suitable for matching the package
+path version-agnostic.
+
+Example:
+Input:
+ mirror://kde//stable/frameworks/5.55/portingAids/kross-5.55.0.zip
+Output:
+ //stable/frameworks/[^/]+/portingAids/
+"
+
+ (define version-regexp
+ ;; regexp for matching versions as used in the ld-lR file
+ (make-regexp
+ (string-join '("^([0-9]+\\.)+[0-9]+-?" ;; 5.12.90, 4.2.0-preview
+ "^[0-9]+$" ;; 20031002
+ ".*-([0-9]+\\.)+[0-9]+$") ;; kdepim-4.6.1
+ "|")))
+
+ (define (version->pattern part)
+ ;; If a path element might be a version, replace it by a catch-all part
+ (if (regexp-exec version-regexp part)
+ "[^/]+"
+ part))
+
+ (let* ((path (uri-path uri))
+ (directory-parts (string-split (dirname path) #\/)))
+ (make-regexp
+ (string-append
+ (string-join (map version->pattern directory-parts) "/")
+ "/"))))
+
+(define (latest-kde-release package)
+ "Return the latest release of PACKAGE, a KDE package, or #f if it could
+not be determined."
+ (let* ((uri (string->uri (origin-uri (package-source package))))
+ (path-rx (uri->kde-path-pattern uri))
+ (name (package-upstream-name package))
+ (files (download.kde.org-files))
+ (relevant (filter (lambda (file)
+ (and (regexp-exec path-rx file)
+ (release-file? name (basename file))))
+ files)))
+ (match (sort relevant (lambda (file1 file2)
+ (version>? (tarball-sans-extension
+ (basename file1))
+ (tarball-sans-extension
+ (basename file2)))))
+ ((and tarballs (reference _ ...))
+ (let* ((version (tarball->version reference))
+ (tarballs (filter (lambda (file)
+ (string=? (tarball-sans-extension
+ (basename file))
+ (tarball-sans-extension
+ (basename reference))))
+ tarballs)))
+ (upstream-source
+ (package name)
+ (version version)
+ (urls (map (lambda (file)
+ (string-append "mirror://kde/" file))
+ tarballs)))))
+ (()
+ #f))))
+
+(define %kde-updater
+ (upstream-updater
+ (name 'kde)
+ (description "Updater for KDE packages")
+ (pred (url-prefix-predicate "mirror://kde/"))
+ (latest latest-kde-release)))
diff --git a/guix/import/opam.scm b/guix/import/opam.scm
index 5dcc0e97a3..7f089a5cf3 100644
--- a/guix/import/opam.scm
+++ b/guix/import/opam.scm
@@ -238,7 +238,9 @@ path to the repository."
(version (find-latest-version name repository))
(file (string-append repository "/packages/" name "/" name "." version "/opam")))
`(("metadata" ,@(get-metadata file))
- ("version" . ,version))))
+ ("version" . ,(if (string-prefix? "v" version)
+ (substring version 1)
+ version)))))
(define (opam->guix-package name)
(and-let* ((opam-file (opam-fetch name))
@@ -283,7 +285,7 @@ path to the repository."
'ocaml-build-system))
,@(if (null? inputs)
'()
- `((inputs ,(list 'quasiquote inputs))))
+ `((propagated-inputs ,(list 'quasiquote inputs))))
,@(if (null? native-inputs)
'()
`((native-inputs ,(list 'quasiquote native-inputs))))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 9b3d80a02e..354cae9c4c 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -437,7 +437,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
(define (pypi-url? url)
(or (string-prefix? "https://pypi.org/" url)
(string-prefix? "https://pypi.python.org/" url)
- (string-prefix? "https://pypi.org/packages" url)))
+ (string-prefix? "https://pypi.org/packages" url)
+ (string-prefix? "https://files.pythonhosted.org/packages" url)))
(let ((source-url (and=> (package-source package) origin-uri))
(fetch-method (and=> (package-source package) origin-method)))
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index 194bea633e..14150201b5 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -95,7 +95,7 @@
(lts-info-packages
(stackage-lts-info-fetch lts-version))))
"Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved
-vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
+version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
release at stackage.org. Return the `package' S-expression corresponding to
that package, or #f on failure. PACKAGES-INFO is the alist with the packages
included in the Stackage LTS release."
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 2a3b7341fb..4694b6e7ef 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -2,7 +2,7 @@
;;; Copyright © 2012, 2013, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
;;;
@@ -212,10 +212,19 @@ with dashes."
(define (beautify-description description)
"Improve the package DESCRIPTION by turning a beginning sentence fragment
into a proper sentence and by using two spaces between sentences."
- (let ((cleaned (if (string-prefix? "A " description)
- (string-append "This package provides a"
- (substring description 1))
- description)))
+ (let ((cleaned (cond
+ ((string-prefix? "A " description)
+ (string-append "This package provides a"
+ (substring description 1)))
+ ((string-prefix? "Provides " description)
+ (string-append "This package provides"
+ (substring description
+ (string-length "Provides"))))
+ ((string-prefix? "Functions " description)
+ (string-append "This package provides functions"
+ (substring description
+ (string-length "Functions"))))
+ (else description))))
;; Use double spacing between sentences
(regexp-substitute/global #f "\\. \\b"
cleaned 'pre ". " 'post)))
@@ -252,6 +261,9 @@ package definition."
(match guix-package
(('package ('name (? string? name)) _ ...)
`(define-public ,(string->symbol name)
+ ,guix-package))
+ (('let anything ('package ('name (? string? name)) _ ...))
+ `(define-public ,(string->symbol name)
,guix-package))))
(define (build-system-modules)
diff --git a/guix/inferior.scm b/guix/inferior.scm
index fee97750b6..d6d2053ab8 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -19,6 +19,8 @@
(define-module (guix inferior)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module ((guix utils)
#:select (%current-system
source-properties->location
@@ -29,7 +31,8 @@
#:select (store-connection-socket
store-connection-major-version
store-connection-minor-version
- store-lift))
+ store-lift
+ &store-protocol-error))
#:use-module ((guix derivations)
#:select (read-derivation-from-file))
#:use-module (guix gexp)
@@ -133,8 +136,8 @@ it's an old Guix."
(object->string
`(begin
(primitive-load ,(search-path %load-path
- "guix/scripts/repl.scm"))
- ((@ (guix scripts repl) machine-repl))))))
+ "guix/repl.scm"))
+ ((@ (guix repl) machine-repl))))))
pipe)))
(define* (port->inferior pipe #:optional (close close-port))
@@ -151,6 +154,7 @@ inferior."
(inferior-eval '(use-modules (guix)) result)
(inferior-eval '(use-modules (gnu)) result)
(inferior-eval '(use-modules (ice-9 match)) result)
+ (inferior-eval '(use-modules (srfi srfi-34)) result)
(inferior-eval '(define %package-table (make-hash-table))
result)
result))
@@ -386,7 +390,7 @@ inferior package."
(cut inferior-package-input-field <> 'package-transitive-propagated-inputs))
(define (%inferior-package-search-paths package field)
- "Return the list of search path specificiations of PACKAGE, an inferior
+ "Return the list of search path specifications of PACKAGE, an inferior
package."
(define paths
(inferior-package-field package
@@ -462,7 +466,13 @@ thus be the code of a one-argument procedure that accepts a store."
(listen socket 1024)
(send-inferior-request
`(let ((proc ,code)
- (socket (socket AF_UNIX SOCK_STREAM 0)))
+ (socket (socket AF_UNIX SOCK_STREAM 0))
+ (error? (if (defined? 'store-protocol-error?)
+ store-protocol-error?
+ nix-protocol-error?))
+ (error-message (if (defined? 'store-protocol-error-message)
+ store-protocol-error-message
+ nix-protocol-error-message)))
(connect socket AF_UNIX ,name)
;; 'port->connection' appeared in June 2018 and we can hardly
@@ -475,7 +485,13 @@ thus be the code of a one-argument procedure that accepts a store."
(dynamic-wind
(const #t)
(lambda ()
- (proc store))
+ ;; Serialize '&store-protocol-error' conditions. The
+ ;; exception serialization mechanism that
+ ;; 'read-repl-response' expects is unsuitable for SRFI-35
+ ;; error conditions, hence this special case.
+ (guard (c ((error? c)
+ `(store-protocol-error ,(error-message c))))
+ `(result ,(proc store))))
(lambda ()
(close-connection store)
(close-port socket)))))
@@ -484,7 +500,14 @@ thus be the code of a one-argument procedure that accepts a store."
((client . address)
(proxy client (store-connection-socket store))))
(close-port socket)
- (read-inferior-response inferior)))))
+
+ (match (read-inferior-response inferior)
+ (('store-protocol-error message)
+ (raise (condition
+ (&store-protocol-error (message message)
+ (status 1)))))
+ (('result result)
+ result))))))
(define* (inferior-package-derivation store package
#:optional
diff --git a/guix/json.scm b/guix/json.scm
new file mode 100644
index 0000000000..20f0bd8f13
--- /dev/null
+++ b/guix/json.scm
@@ -0,0 +1,62 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 json)
+ #:use-module (json)
+ #:use-module (srfi srfi-9)
+ #:export (define-json-mapping))
+
+;;; Commentary:
+;;;
+;;; Helpers to map JSON objects to SRFI-9 records. Taken from (guix swh).
+;;;
+;;; Code:
+
+(define-syntax-rule (define-json-reader json->record ctor spec ...)
+ "Define JSON->RECORD as a procedure that converts a JSON representation,
+read from a port, string, or hash table, into a record created by CTOR and
+following SPEC, a series of field specifications."
+ (define (json->record input)
+ (let ((table (cond ((port? input)
+ (json->scm input))
+ ((string? input)
+ (json-string->scm input))
+ ((or (null? input) (pair? input))
+ input))))
+ (let-syntax ((extract-field (syntax-rules ()
+ ((_ table (field key json->value))
+ (json->value (assoc-ref table key)))
+ ((_ table (field key))
+ (assoc-ref table key))
+ ((_ table (field))
+ (assoc-ref table
+ (symbol->string 'field))))))
+ (ctor (extract-field table spec) ...)))))
+
+(define-syntax-rule (define-json-mapping rtd ctor pred json->record
+ (field getter spec ...) ...)
+ "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
+and define JSON->RECORD as a conversion from JSON to a record of this type."
+ (begin
+ (define-record-type rtd
+ (ctor field ...)
+ pred
+ (field getter) ...)
+
+ (define-json-reader json->record ctor
+ (field spec ...) ...)))
diff --git a/guix/lint.scm b/guix/lint.scm
index 7a2bf5a347..03a8e88225 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -44,6 +44,8 @@
#:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
#:use-module (guix gnu-maintenance)
#:use-module (guix cve)
+ #:use-module ((guix swh) #:hide (origin?))
+ #:autoload (guix git-download) (git-reference?)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
@@ -80,6 +82,7 @@
check-vulnerabilities
check-for-updates
check-formatting
+ check-archival
lint-warning
lint-warning?
@@ -522,7 +525,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
(define (validate-uri uri package field)
"Return #t if the given URI can be reached, otherwise return a warning for
-PACKAGE mentionning the FIELD."
+PACKAGE mentioning the FIELD."
(let-values (((status argument)
(probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
@@ -950,6 +953,16 @@ display a message including MESSAGE and return ERROR-VALUE."
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))))))
@@ -1008,8 +1021,8 @@ the NIST server non-fatal."
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
(match (with-networking-fail-safe
- (G_ "while retrieving upstream info for '~a'")
- (list (package-name package))
+ (format #f (G_ "while retrieving upstream info for '~a'")
+ (package-name package))
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
@@ -1023,6 +1036,93 @@ the NIST server non-fatal."
'()))
(#f '()))) ; cannot find newer upstream release
+
+(define (check-archival package)
+ "Check whether PACKAGE's source code is archived on Software Heritage. If
+it's not, and if its source code is a VCS snapshot, then send a \"save\"
+request to Software Heritage.
+
+Software Heritage imposes limits on the request rate per client IP address.
+This checker prints a notice and stops doing anything once that limit has been
+reached."
+ (define (response->warning url method response)
+ (if (request-rate-limit-reached? url method)
+ (list (make-warning package
+ (G_ "Software Heritage rate limit reached; \
+try again later")
+ #:field 'source))
+ (list (make-warning package
+ (G_ "'~a' returned ~a")
+ (list url (response-code response))
+ #:field 'source))))
+
+ (define skip-key (gensym "skip-archival-check"))
+
+ (define (skip-when-limit-reached url method)
+ (or (not (request-rate-limit-reached? url method))
+ (throw skip-key #t)))
+
+ (parameterize ((%allow-request? skip-when-limit-reached))
+ (catch #t
+ (lambda ()
+ (match (and (origin? (package-source package))
+ (package-source package))
+ (#f ;no source
+ '())
+ ((= origin-uri (? git-reference? reference))
+ (define url
+ (git-reference-url reference))
+ (define commit
+ (git-reference-commit reference))
+
+ (match (if (commit-id? commit)
+ (or (lookup-revision commit)
+ (lookup-origin-revision url commit))
+ (lookup-origin-revision url commit))
+ ((? revision? revision)
+ '())
+ (#f
+ ;; Revision is missing from the archive, attempt to save it.
+ (catch 'swh-error
+ (lambda ()
+ (save-origin (git-reference-url reference) "git")
+ (list (make-warning
+ package
+ ;; TRANSLATORS: "Software Heritage" is a proper noun
+ ;; that must remain untranslated. See
+ ;; <https://www.softwareheritage.org>.
+ (G_ "scheduled Software Heritage archival")
+ #:field 'source)))
+ (lambda (key url method response . _)
+ (cond ((= 429 (response-code response))
+ (list (make-warning
+ package
+ (G_ "archival rate limit exceeded; \
+try again later")
+ #:field 'source)))
+ (else
+ (response->warning url method response))))))))
+ ((? origin? origin)
+ ;; Since "save" origins are not supported for non-VCS source, all
+ ;; we can do is tell whether a given tarball is available or not.
+ (if (origin-sha256 origin) ;XXX: for ungoogled-chromium
+ (match (lookup-content (origin-sha256 origin) "sha256")
+ (#f
+ (list (make-warning package
+ (G_ "source not archived on Software \
+Heritage")
+ #:field 'source)))
+ ((? content?)
+ '()))
+ '()))))
+ (match-lambda*
+ ((key url method response)
+ (response->warning url method response))
+ ((key . args)
+ (if (eq? key skip-key)
+ '()
+ (apply throw key args)))))))
+
;;;
;;; Source code formatting.
@@ -1031,7 +1131,7 @@ the NIST server non-fatal."
(define (report-tabulations package line line-number)
"Warn about tabulations found in LINE."
(match (string-index line #\tab)
- (#f #t)
+ (#f #f)
(index
(make-warning package
(G_ "tabulation on line ~a, column ~a")
@@ -1043,44 +1143,44 @@ the NIST server non-fatal."
(define (report-trailing-white-space package line line-number)
"Warn about trailing white space in LINE."
- (unless (or (string=? line (string-trim-right line))
- (string=? line (string #\page)))
- (make-warning package
- (G_ "trailing white space on line ~a")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
+ (and (not (or (string=? line (string-trim-right line))
+ (string=? line (string #\page))))
+ (make-warning package
+ (G_ "trailing white space on line ~a")
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define (report-long-line package line line-number)
"Emit a warning if LINE is too long."
;; Note: We don't warn at 80 characters because sometimes hashes and URLs
;; make it hard to fit within that limit and we want to avoid making too
;; much noise.
- (when (> (string-length line) 90)
- (make-warning package
- (G_ "line ~a is way too long (~a characters)")
- (list line-number (string-length line))
- #:location
- (location (package-file package)
- line-number
- 0))))
+ (and (> (string-length line) 90)
+ (make-warning package
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %hanging-paren-rx
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
- (when (regexp-exec %hanging-paren-rx line)
- (make-warning package
- (G_ "parentheses feel lonely, \
+ (and (regexp-exec %hanging-paren-rx line)
+ (make-warning package
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1130,11 +1230,9 @@ them for PACKAGE."
warnings
(if (< line-number starting-line)
'()
- (filter
- lint-warning?
- (map (lambda (report)
- (report package line line-number))
- reporters))))))))))))
+ (filter-map (lambda (report)
+ (report package line line-number))
+ reporters)))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
@@ -1229,7 +1327,11 @@ or a list thereof")
(lint-checker
(name 'refresh)
(description "Check the package for new upstream releases")
- (check check-for-updates))))
+ (check check-for-updates))
+ (lint-checker
+ (name 'archival)
+ (description "Ensure source code archival on Software Heritage")
+ (check check-archival))))
(define %all-checkers
(append %local-checkers
diff --git a/guix/packages.scm b/guix/packages.scm
index c94a651f27..f2c94c7bc2 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -351,7 +352,7 @@ object."
(match (package-location package)
(($ <location> file line column)
- (catch 'system
+ (catch 'system-error
(lambda ()
;; In general we want to keep relative file names for modules.
(with-fluids ((%file-port-name-canonicalization 'relative))
@@ -505,11 +506,17 @@ specifies modules in scope when evaluating SNIPPET."
(and=> (file-extension file-name)
(cut string-every char-set:hex-digit <>)))
+ (define (checkout? directory)
+ ;; Return true if DIRECTORY is a checkout (git, svn, etc).
+ (string-suffix? "-checkout" directory))
+
(define (tarxz-name file-name)
;; Return a '.tar.xz' file name based on FILE-NAME.
- (let ((base (if (numeric-extension? file-name)
- original-file-name
- (file-sans-extension file-name))))
+ (let ((base (cond ((numeric-extension? file-name)
+ original-file-name)
+ ((checkout? file-name)
+ (string-drop-right file-name 9))
+ (else (file-sans-extension file-name)))))
(string-append base
(if (equal? (file-extension base) "tar")
".xz"
@@ -642,13 +649,11 @@ specifies modules in scope when evaluating SNIPPET."
(let ((name (tarxz-name original-file-name)))
(gexp->derivation name build
- ;; TODO: Remove this on the next rebuild cycle.
- #:pre-load-modules? #f
-
#:graft? #f
#:system system
- #:deprecation-warnings #t ;to avoid a rebuild
- #:guile-for-build guile-for-build))))
+ #:guile-for-build guile-for-build
+ #:properties `((type . origin)
+ (patches . ,(length patches)))))))
(define (transitive-inputs inputs)
"Return the closure of INPUTS when considering the 'propagated-inputs'
@@ -762,23 +767,29 @@ in INPUTS and their transitive propagated inputs."
(transitive-inputs inputs)))
(define package-transitive-supported-systems
- (mlambdaq (package)
- "Return the intersection of the systems supported by PACKAGE and those
+ (let ()
+ (define supported-systems
+ (mlambda (package system)
+ (parameterize ((%current-system system))
+ (fold (lambda (input systems)
+ (match input
+ ((label (? package? package) . _)
+ (lset-intersection string=? systems
+ (supported-systems package system)))
+ (_
+ systems)))
+ (package-supported-systems package)
+ (bag-direct-inputs (package->bag package))))))
+
+ (lambda* (package #:optional (system (%current-system)))
+ "Return the intersection of the systems supported by PACKAGE and those
supported by its dependencies."
- (fold (lambda (input systems)
- (match input
- ((label (? package? p) . _)
- (lset-intersection
- string=? systems (package-transitive-supported-systems p)))
- (_
- systems)))
- (package-supported-systems package)
- (bag-direct-inputs (package->bag package)))))
+ (supported-systems package system))))
(define* (supported-package? package #:optional (system (%current-system)))
"Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
dependencies are known to build on SYSTEM."
- (member system (package-transitive-supported-systems package)))
+ (member system (package-transitive-supported-systems package system)))
(define (bag-direct-inputs bag)
"Same as 'package-direct-inputs', but applied to a bag."
@@ -796,7 +807,8 @@ dependencies are known to build on SYSTEM."
(define (bag-transitive-host-inputs bag)
"Same as 'package-transitive-target-inputs', but applied to a bag."
- (transitive-inputs (bag-host-inputs bag)))
+ (parameterize ((%current-target-system (bag-target bag)))
+ (transitive-inputs (bag-host-inputs bag))))
(define (bag-transitive-target-inputs bag)
"Return the \"target inputs\" of BAG, recursively."
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..c00585de74 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -19,13 +19,18 @@
(define-module (guix remote)
#:use-module (guix ssh)
#:use-module (guix gexp)
+ #:use-module (guix i18n)
#:use-module (guix inferior)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix modules)
#:use-module (guix derivations)
+ #:use-module (guix utils)
#:use-module (ssh popen)
+ #:use-module (ssh channel)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:export (remote-eval))
@@ -40,29 +45,44 @@
;;;
;;; Code:
-(define (remote-pipe-for-gexp lowered session)
- "Return a remote pipe for the given SESSION to evaluate LOWERED."
+(define* (remote-pipe-for-gexp lowered session #:optional become-command)
+ "Return a remote pipe for the given SESSION to evaluate LOWERED. If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
(define shell-quote
(compose object->string object->string))
- (apply open-remote-pipe* session OPEN_READ
- (string-append (derivation-input-output-path
- (lowered-gexp-guile lowered))
- "/bin/guile")
- "--no-auto-compile"
- (append (append-map (lambda (directory)
- `("-L" ,directory))
- (lowered-gexp-load-path lowered))
- (append-map (lambda (directory)
- `("-C" ,directory))
- (lowered-gexp-load-path lowered))
- `("-c"
- ,(shell-quote (lowered-gexp-sexp lowered))))))
+ (define repl-command
+ (append (or become-command '())
+ (list
+ (string-append (derivation-input-output-path
+ (lowered-gexp-guile lowered))
+ "/bin/guile")
+ "--no-auto-compile")
+ (append-map (lambda (directory)
+ `("-L" ,directory))
+ (lowered-gexp-load-path lowered))
+ (append-map (lambda (directory)
+ `("-C" ,directory))
+ (lowered-gexp-load-path lowered))
+ `("-c"
+ ,(shell-quote (lowered-gexp-sexp lowered)))))
-(define (%remote-eval lowered session)
+ (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
+ (when (eof-object? (peek-char pipe))
+ (let ((status (channel-get-exit-status pipe)))
+ (close-port pipe)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "remote command '~{~a~^ ~}' failed \
+with status ~a")
+ repl-command status)))))))
+ pipe))
+
+(define* (%remote-eval lowered session #:optional become-command)
"Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the
-prerequisites of EXP are already available on the host at SESSION."
- (let* ((pipe (remote-pipe-for-gexp lowered session))
+prerequisites of EXP are already available on the host at SESSION. If
+BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
+ (let* ((pipe (remote-pipe-for-gexp lowered session become-command))
(result (read-repl-response pipe)))
(close-port pipe)
result))
@@ -71,7 +91,7 @@ prerequisites of EXP are already available on the host at SESSION."
"Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
result to the current output port using the (guix repl) protocol."
(define program
- (scheme-file "remote-exp.scm" exp))
+ (program-file "remote-exp.scm" exp))
(with-imported-modules (source-module-closure '((guix repl)))
#~(begin
@@ -89,17 +109,21 @@ result to the current output port using the (guix repl) protocol."
(define* (remote-eval exp session
#:key
(build-locally? #t)
+ (system (%current-system))
(module-path %load-path)
- (socket-name "/var/guix/daemon-socket/socket"))
+ (socket-name (%daemon-socket-uri))
+ (become-command #f))
"Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that
all the elements EXP refers to are built and deployed to SESSION beforehand.
When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
the remote store afterwards; otherwise, dependencies are built directly on the
remote store."
- (mlet %store-monad ((lowered (lower-gexp (trampoline exp)
- #:module-path %load-path))
- (remote -> (connect-to-remote-daemon session
- socket-name)))
+ (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
+ #:system system
+ #:guile-for-build #f
+ #:module-path %load-path))
+ (remote -> (connect-to-remote-daemon session
+ socket-name)))
(define inputs
(cons (lowered-gexp-guile lowered)
(lowered-gexp-inputs lowered)))
@@ -115,7 +139,7 @@ remote store."
(built-derivations inputs)
((store-lift send-files) to-send remote #:recursive? #t)
(return (close-connection remote))
- (return (%remote-eval lowered session))))
+ (return (%remote-eval lowered session become-command))))
(let ((to-send (append (map (compose derivation-file-name
derivation-input-derivation)
inputs)
@@ -124,4 +148,4 @@ remote store."
((store-lift send-files) to-send remote #:recursive? #t)
(return (build-derivations remote inputs))
(return (close-connection remote))
- (return (%remote-eval lowered session)))))))
+ (return (%remote-eval lowered session become-command)))))))
diff --git a/guix/repl.scm b/guix/repl.scm
index 5cff5c71e9..1ead18c53b 100644
--- a/guix/repl.scm
+++ b/guix/repl.scm
@@ -17,7 +17,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix repl)
- #:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (send-repl-response
machine-repl))
@@ -37,9 +36,8 @@
((_ pred rest ...)
(or (pred x)
(one-of rest ...))))))
- (one-of symbol? string? pair? null? vector?
- bytevector? number? boolean?)))
-
+ (one-of symbol? string? keyword? pair? null? array?
+ number? boolean?)))
(define (send-repl-response exp output)
"Write the response corresponding to the evaluation of EXP to PORT, an
diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm
index d598f5cac4..51b616b384 100644
--- a/guix/scripts/container/exec.scm
+++ b/guix/scripts/container/exec.scm
@@ -38,7 +38,7 @@
(define (show-help)
(display (G_ "Usage: guix container exec PID COMMAND [ARGS...]
-Execute COMMMAND within the container process PID.\n"))
+Execute COMMAND within the container process PID.\n"))
(newline)
(display (G_ "
-h, --help display this help and exit"))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index ebc99e52cc..f311587ec3 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -26,8 +26,11 @@
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix grafts)
+ #:use-module (guix status)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
#:export (guix-deploy))
@@ -43,8 +46,6 @@
(define (show-help)
(display (G_ "Usage: guix deploy [OPTION] FILE...
Perform the deployment specified by FILE.\n"))
- (display (G_ "
- -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
(show-build-options-help)
(newline)
(display (G_ "
@@ -52,6 +53,8 @@ Perform the deployment specified by FILE.\n"))
(display (G_ "
-V, --version display version information and exit"))
(newline)
+ (display (G_ "
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
(show-bug-report-information))
(define %options
@@ -63,15 +66,24 @@ Perform the deployment specified by FILE.\n"))
(lambda (opt name arg result)
(alist-cons 'system arg
(alist-delete 'system result eq?))))
+ (option '(#\v "verbosity") #t #f
+ (lambda (opt name arg result)
+ (let ((level (string->number* arg)))
+ (alist-cons 'verbosity level
+ (alist-delete 'verbosity result)))))
+
%standard-build-options))
(define %default-options
- `((system . ,(%current-system))
+ ;; Alist of default option values.
+ `((verbosity . 1)
+ (debug . 0)
+ (graft? . #t)
(substitutes? . #t)
(build-hook? . #t)
- (graft? . #t)
- (debug . 0)
- (verbosity . 1)))
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)))
(define (load-source-file file)
"Load FILE as a user module."
@@ -84,15 +96,27 @@ Perform the deployment specified by FILE.\n"))
(define (guix-deploy . args)
(define (handle-argument arg result)
(alist-cons 'file arg result))
+
(let* ((opts (parse-command-line args %options (list %default-options)
#:argument-handler handle-argument))
(file (assq-ref opts 'file))
(machines (or (and file (load-source-file file)) '())))
- (with-store store
- (set-build-options-from-command-line store opts)
- (for-each (lambda (machine)
- (info (G_ "deploying to ~a...") (machine-display-name machine))
- (parameterize ((%current-system (assq-ref opts 'system))
- (%graft? (assq-ref opts 'graft?)))
- (run-with-store store (deploy-machine machine))))
- machines))))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (with-store store
+ (set-build-options-from-command-line store opts)
+ (for-each (lambda (machine)
+ (info (G_ "deploying to ~a...~%")
+ (machine-display-name machine))
+ (parameterize ((%graft? (assq-ref opts 'graft?)))
+ (guard (c ((message-condition? c)
+ (report-error (G_ "failed to deploy ~a: ~a~%")
+ (machine-display-name machine)
+ (condition-message c)))
+ ((deploy-error? c)
+ (when (deploy-error-should-roll-back c)
+ (info (G_ "rolling back ~a...~%")
+ (machine-display-name machine))
+ (run-with-store store (roll-back-machine machine)))
+ (apply throw (deploy-error-captured-args c))))
+ (run-with-store store (deploy-machine machine)))))
+ machines)))))
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index fa6b6cae37..99a88c50fa 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -153,30 +153,9 @@ in the format specified by FMT."
(generation-number profile))
(define channels
- (map (lambda (entry)
- (match (assq 'source (manifest-entry-properties entry))
- (('source ('repository ('version 0)
- ('url url)
- ('branch branch)
- ('commit commit)
- _ ...))
- (channel (name (string->symbol (manifest-entry-name entry)))
- (url url)
- (commit commit)))
-
- ;; Pre-0.15.0 Guix does not provide that information,
- ;; so there's not much we can do in that case.
- (_ (channel (name 'guix)
- (url "?")
- (commit "?")))))
-
- ;; Show most recently installed packages last.
- (reverse
- (manifest-entries
- (profile-manifest
- (if (zero? number)
- profile
- (generation-file-name profile number)))))))
+ (profile-channels (if (zero? number)
+ profile
+ (generation-file-name profile number))))
(match fmt
('human
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index d8fe71ce12..22cd75ea0b 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -33,6 +33,7 @@
#:use-module (web uri)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-14)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (rnrs bytevectors)
@@ -54,9 +55,23 @@
(url-fetch url file #:mirrors %mirrors)))
file))
+(define (ensure-valid-store-file-name name)
+ "Replace any character not allowed in a stror name by an underscore."
+
+ (define valid
+ ;; according to nix/libstore/store-api.cc
+ (string->char-set (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "abcdefghijklmnopqrstuvwxyz"
+ "0123456789" "+-._?=")))
+ (string-map (lambda (c)
+ (if (char-set-contains? valid c) c #\_))
+ name))
+
+
(define* (download-to-store* url #:key (verify-certificate? #t))
(with-store store
(download-to-store store url
+ (ensure-valid-store-file-name (basename url))
#:verify-certificate? verify-certificate?)))
(define %default-options
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index cf58768300..d78ca0f303 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -29,7 +29,7 @@
#:use-module (guix search-paths)
#:use-module (guix build utils)
#:use-module (guix monads)
- #:use-module ((guix gexp) #:select (lower-inputs))
+ #:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix scripts)
#:use-module (guix scripts build)
#:use-module (gnu build linux-container)
@@ -40,7 +40,8 @@
#:use-module (gnu packages bash)
#:use-module (gnu packages commencement)
#:use-module (gnu packages guile)
- #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
+ #:use-module ((gnu packages bootstrap)
+ #:select (bootstrap-executable %bootstrap-guile))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
@@ -452,7 +453,7 @@ regexps in WHITE-LIST."
(define* (launch-environment/container #:key command bash user user-mappings
profile manifest link-profile? network?
- map-cwd?)
+ map-cwd? (white-list '()))
"Run COMMAND within a container that features the software in PROFILE.
Environment variables are set according to the search paths of MANIFEST.
The global shell is BASH, a file name for a GNU Bash binary in the
@@ -461,7 +462,14 @@ USER-MAPPINGS, a list of file system mappings, contains the user-specified
host file systems to mount inside the container. If USER is not #f, each
target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
-~/.guix-profile to the environment profile."
+~/.guix-profile to the environment profile.
+
+Preserve environment variables whose name matches the one of the regexps in
+WHILE-LIST."
+ (define (optional-mapping->fs mapping)
+ (and (file-exists? (file-system-mapping-source mapping))
+ (file-system-mapping->bind-mount mapping)))
+
(mlet %store-monad ((reqs (inputs->requisites
(list (direct-store-path bash) profile))))
(return
@@ -483,6 +491,11 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
(group-entry (gid 65534) ;the overflow GID
(name "overflow"))))
(home-dir (password-entry-directory passwd))
+ (environ (filter (match-lambda
+ ((variable . value)
+ (find (cut regexp-exec <> variable)
+ white-list)))
+ (get-environment-variables)))
;; Bind-mount all requisite store items, user-specified mappings,
;; /bin/sh, the current working directory, and possibly networking
;; configuration files within the container.
@@ -498,11 +511,6 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
(target cwd)
(writable? #t)))
'())))
- ;; When in Rome, do as Nix build.cc does: Automagically
- ;; map common network configuration files.
- (if network?
- %network-file-mappings
- '())
;; Mappings for the union closure of all inputs.
(map (lambda (dir)
(file-system-mapping
@@ -511,6 +519,10 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
(writable? #f)))
reqs)))
(file-systems (append %container-file-systems
+ (if network?
+ (filter-map optional-mapping->fs
+ %network-file-mappings)
+ '())
(map file-system-mapping->bind-mount
mappings))))
(exit/status
@@ -552,6 +564,12 @@ will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
(override-user-dir user home cwd)
home-dir))
+ ;; Set environment variables that match WHITE-LIST.
+ (for-each (match-lambda
+ ((variable . value)
+ (setenv variable value)))
+ environ)
+
(primitive-exit/status
;; A container's environment is already purified, so no need to
;; request it be purified again.
@@ -613,8 +631,7 @@ Otherwise, return the derivation for the Bash package."
(package->derivation bash))
;; Use the bootstrap Bash instead.
((and container? bootstrap?)
- (interned-file
- (search-bootstrap-binary "bash" system)))
+ (lower-object (bootstrap-executable "bash" system)))
(else
(return #f)))))
@@ -747,7 +764,7 @@ message if any test fails."
(container?
(let ((bash-binary
(if bootstrap?
- bash
+ (derivation->output-path bash)
(string-append (derivation->output-path bash)
"/bin/sh"))))
(launch-environment/container #:command command
@@ -756,6 +773,7 @@ message if any test fails."
#:user-mappings mappings
#:profile profile
#:manifest manifest
+ #:white-list white-list
#:link-profile? link-prof?
#:network? network?
#:map-cwd? (not no-cwd?))))
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 31657326b6..3f20a2e192 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -57,6 +57,8 @@ Invoke the garbage collector.\n"))
(display (G_ "
--list-roots list the user's garbage collector roots"))
(display (G_ "
+ --list-busy list store items used by running processes"))
+ (display (G_ "
--optimize optimize the store by deduplicating identical files"))
(display (G_ "
--list-dead list dead paths"))
@@ -174,6 +176,10 @@ is deprecated; use '-D'~%"))
(lambda (opt name arg result)
(alist-cons 'action 'list-roots
(alist-delete 'action result))))
+ (option '("list-busy") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'action 'list-busy
+ (alist-delete 'action result))))
(option '("list-dead") #f #f
(lambda (opt name arg result)
(alist-cons 'action 'list-dead
@@ -265,6 +271,12 @@ is deprecated; use '-D'~%"))
(newline))
roots)))
+ (define (list-busy)
+ ;; List store items used by running processes.
+ (for-each (lambda (item)
+ (display item) (newline))
+ (busy-store-items)))
+
(with-error-handling
(let* ((opts (parse-options))
(store (open-connection))
@@ -305,6 +317,9 @@ is deprecated; use '-D'~%"))
((list-roots)
(assert-no-extra-arguments)
(list-roots))
+ ((list-busy)
+ (assert-no-extra-arguments)
+ (list-busy))
((delete)
(delete-paths store (map direct-store-path paths)))
((list-references)
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index 0b326e1049..c6cc93fad8 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -113,7 +114,8 @@ Run IMPORTER with ARGS.\n"))
(pretty-print expr (newline-rewriting-port
(current-output-port))))))
(match (apply (resolve-importer importer) args)
- ((and expr ('package _ ...))
+ ((and expr (or ('package _ ...)
+ ('let _ ...)))
(print expr))
((? list? expressions)
(for-each (lambda (expr)
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index 794fb710cd..b6592f78a9 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015, 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +22,7 @@
#:use-module (guix utils)
#:use-module (guix scripts)
#:use-module (guix import cran)
+ #:use-module (guix import utils)
#:use-module (guix scripts import)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
@@ -96,11 +97,7 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
((package-name)
(if (assoc-ref opts 'recursive)
;; Recursive import
- (map (match-lambda
- ((and ('package ('name name) . rest) pkg)
- `(define-public ,(string->symbol name)
- ,pkg))
- (_ #f))
+ (map package->definition
(reverse
(stream->list
(cran-recursive-import package-name
diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm
index cab9a4397b..4690cceb4d 100644
--- a/guix/scripts/import/crate.scm
+++ b/guix/scripts/import/crate.scm
@@ -2,6 +2,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2019 Martin Becze <mjbecze@riseup.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -27,6 +28,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-41)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-crate))
@@ -43,6 +45,9 @@
(display (G_ "Usage: guix import crate PACKAGE-NAME
Import and convert the crate.io package for PACKAGE-NAME.\n"))
(display (G_ "
+ -r, --recursive import packages recursively"))
+ (newline)
+ (display (G_ "
-h, --help display this help and exit"))
(display (G_ "
-V, --version display version information and exit"))
@@ -58,6 +63,9 @@ Import and convert the crate.io package for PACKAGE-NAME.\n"))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix import crate")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
%standard-import-options))
@@ -75,19 +83,34 @@ Import and convert the crate.io package for PACKAGE-NAME.\n"))
(alist-cons 'argument arg result))
%default-options))
+
(let* ((opts (parse-options))
(args (filter-map (match-lambda
- (('argument . value)
- value)
- (_ #f))
+ (('argument . value)
+ value)
+ (_ #f))
(reverse opts))))
(match args
- ((package-name)
- (let ((sexp (crate->guix-package package-name)))
- (unless sexp
- (leave (G_ "failed to download meta-data for package '~a'~%")
- package-name))
- sexp))
+ ((spec)
+ (define-values (name version)
+ (package-name->name+version spec))
+
+ (if (assoc-ref opts 'recursive)
+ (map (match-lambda
+ ((and ('package ('name name) . rest) pkg)
+ `(define-public ,(string->symbol name)
+ ,pkg))
+ (_ #f))
+ (reverse
+ (stream->list
+ (crate-recursive-import name))))
+ (let ((sexp (crate->guix-package name version)))
+ (unless sexp
+ (leave (G_ "failed to download meta-data for package '~a'~%")
+ (if version
+ (string-append name "@" version)
+ name)))
+ sexp)))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index ee1c826d2e..1668d02992 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -46,9 +46,9 @@
(lambda (lint-warning)
(let ((package (lint-warning-package lint-warning))
(loc (lint-warning-location lint-warning)))
- (warning loc (G_ "~a@~a: ~a~%")
- (package-name package) (package-version package)
- (lint-warning-message lint-warning))))
+ (info loc (G_ "~a@~a: ~a~%")
+ (package-name package) (package-version package)
+ (lint-warning-message lint-warning))))
warnings))
(define (run-checkers package checkers)
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 0c0dd9d516..bb307cefd1 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -243,7 +243,8 @@ instead of '~a' of type '~a'~%")
;; of these; if we fail, that means all the build slots are already taken.
;; Inspired by Nix's build-remote.pl.
(string-append (string-append %state-directory "/offload/"
- (build-machine-name machine)
+ (build-machine-name machine) ":"
+ (number->string (build-machine-port machine))
"/" (number->string slot))))
(define (acquire-build-slot machine)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index fdb98983bf..920d6c01fe 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -490,7 +490,8 @@ the image."
#~(begin
(use-modules (guix docker) (guix build store-copy)
(guix profiles) (guix search-paths)
- (srfi srfi-19) (ice-9 match))
+ (srfi srfi-1) (srfi srfi-19)
+ (ice-9 match))
(define environment
(map (match-lambda
@@ -499,6 +500,35 @@ the image."
value)))
(profile-search-paths #$profile)))
+ (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)))
+ `((directory ,parent)
+ (,source -> ,target))))))
+
+ (define directives
+ ;; Create a /tmp directory, as some programs expect it, and
+ ;; create SYMLINKS.
+ `((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" (string-append #$archiver "/bin"))
(build-docker-image #$output
@@ -506,6 +536,7 @@ the image."
(call-with-input-file "profile"
read-reference-graph))
#$profile
+ #:repository tag
#:database #+database
#:system (or #$target (utsname:machine (uname)))
#:environment environment
@@ -513,7 +544,7 @@ the image."
#$(and entry-point
#~(list (string-append #$profile "/"
#$entry-point)))
- #:symlinks '#$symlinks
+ #:extra-files directives
#:compressor '#$(compressor-command compressor)
#:creation-time (make-time time-utc 0 1))))))
@@ -543,9 +574,9 @@ the image."
"Return the C compiler that uses the bootstrap toolchain. This is used only
by '--bootstrap', for testing purposes."
(define bootstrap-toolchain
- (list (first (assoc-ref %bootstrap-inputs "gcc"))
- (first (assoc-ref %bootstrap-inputs "binutils"))
- (first (assoc-ref %bootstrap-inputs "libc"))))
+ (list (first (assoc-ref (%bootstrap-inputs) "gcc"))
+ (first (assoc-ref (%bootstrap-inputs) "binutils"))
+ (first (assoc-ref (%bootstrap-inputs) "libc"))))
(c-compiler bootstrap-toolchain
#:guile %bootstrap-guile))
@@ -611,8 +642,13 @@ please email '~a'~%")
;;;
(define* (wrapped-package package
- #:optional (compiler (c-compiler))
+ #:optional
+ (output* "out")
+ (compiler (c-compiler))
#:key proot?)
+ "Return the OUTPUT of PACKAGE with its binaries wrapped such that they are
+relocatable. When PROOT? is true, include PRoot in the result and use it as a
+last resort for relocation."
(define runner
(local-file (search-auxiliary-file "run-in-namespace.c")))
@@ -629,6 +665,14 @@ please email '~a'~%")
(ice-9 ftw)
(ice-9 match))
+ (define input
+ ;; The OUTPUT* output of PACKAGE.
+ (ungexp package output*))
+
+ (define target
+ ;; The output we are producing.
+ (ungexp output output*))
+
(define (strip-store-prefix file)
;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return
;; "/bin/foo".
@@ -648,7 +692,7 @@ please email '~a'~%")
(("@STORE_DIRECTORY@") (%store-directory)))
(let* ((base (strip-store-prefix program))
- (result (string-append #$output "/" base))
+ (result (string-append target "/" base))
(proot #$(and proot?
#~(string-drop
#$(file-append (proot) "/bin/proot")
@@ -667,18 +711,18 @@ please email '~a'~%")
;; Link the top-level files of PACKAGE so that search paths are
;; properly defined in PROFILE/etc/profile.
- (mkdir #$output)
+ (mkdir target)
(for-each (lambda (file)
(unless (member file '("." ".." "bin" "sbin" "libexec"))
- (let ((file* (string-append #$package "/" file)))
- (symlink (relative-file-name #$output file*)
- (string-append #$output "/" file)))))
- (scandir #$package))
+ (let ((file* (string-append input "/" file)))
+ (symlink (relative-file-name target file*)
+ (string-append target "/" file)))))
+ (scandir input))
(for-each build-wrapper
- (append (find-files #$(file-append package "/bin"))
- (find-files #$(file-append package "/sbin"))
- (find-files #$(file-append package "/libexec")))))))
+ (append (find-files (string-append input "/bin"))
+ (find-files (string-append input "/sbin"))
+ (find-files (string-append input "/libexec")))))))
(computed-file (string-append
(cond ((package? package)
@@ -691,14 +735,18 @@ please email '~a'~%")
"R")
build))
+(define (wrapped-manifest-entry entry . args)
+ (manifest-entry
+ (inherit entry)
+ (item (apply wrapped-package
+ (manifest-entry-item entry)
+ (manifest-entry-output entry)
+ args))))
+
(define (map-manifest-entries proc manifest)
"Apply PROC to all the entries of MANIFEST and return a new manifest."
(make-manifest
- (map (lambda (entry)
- (manifest-entry
- (inherit entry)
- (item (proc (manifest-entry-item entry)))))
- (manifest-entries manifest))))
+ (map proc (manifest-entries manifest))))
;;;
@@ -909,7 +957,8 @@ Create a bundle of PACKAGE.\n"))
(list (transform store package) output))
((? package? package)
(list (transform store package) "out")))
- (filter-map maybe-package-argument opts)))
+ (reverse
+ (filter-map maybe-package-argument opts))))
(manifest-file (assoc-ref opts 'manifest)))
(define properties
(if (assoc-ref opts 'save-provenance?)
@@ -960,7 +1009,7 @@ Create a bundle of PACKAGE.\n"))
;; 'glibc-bootstrap' lacks 'libc.a'.
(if relocatable?
(map-manifest-entries
- (cut wrapped-package <> #:proot? proot?)
+ (cut wrapped-manifest-entry <> #:proot? proot?)
manifest)
manifest)))
(pack-format (assoc-ref opts 'format))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index a43c96516f..1a58d43e5c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -39,6 +39,7 @@
#:use-module (guix scripts)
#:use-module (guix scripts build)
#:autoload (guix describe) (package-provenance)
+ #:autoload (guix store roots) (gc-roots)
#:use-module ((guix build utils)
#:select (directory-exists? mkdir-p))
#:use-module (ice-9 format)
@@ -359,6 +360,8 @@ Install, remove, or upgrade packages in a single transaction.\n"))
switch to a generation matching PATTERN"))
(display (G_ "
-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
+ (display (G_ "
+ --list-profiles list the user's profiles"))
(newline)
(display (G_ "
--allow-collisions do not treat collisions in the profile as an error"))
@@ -458,6 +461,11 @@ command-line option~%")
(values (cons `(query list-generations ,arg)
result)
#f)))
+ (option '("list-profiles") #f #f
+ (lambda (opt name arg result arg-handler)
+ (values (cons `(query list-profiles #t)
+ result)
+ #f)))
(option '(#\d "delete-generations") #f #t
(lambda (opt name arg result arg-handler)
(values (alist-cons 'delete-generations arg
@@ -607,7 +615,11 @@ and upgrades."
(let-values (((package output)
(specification->package+output spec)))
(package->manifest-entry* package output))))
- (_ #f))
+ (('install . obj)
+ (leave (G_ "cannot install non-package object: ~s~%")
+ obj))
+ (_
+ #f))
opts))
(fold manifest-transaction-install-entry
@@ -746,6 +758,19 @@ processed, #f otherwise."
(string<? name1 name2))))))
#t))
+ (('list-profiles _)
+ (let ((profiles (delete-duplicates
+ (filter-map (lambda (root)
+ (and (or (zero? (getuid))
+ (user-owned? root))
+ (generation-profile root)))
+ (gc-roots)))))
+ (leave-on-EPIPE
+ (for-each (lambda (profile)
+ (display (user-friendly-profile profile))
+ (newline))
+ (sort profiles string<?)))))
+
(('search _)
(let* ((patterns (filter-map (match-lambda
(('query 'search rx) rx)
@@ -760,7 +785,8 @@ processed, #f otherwise."
(('show requested-name)
(let-values (((name version)
(package-name->name+version requested-name)))
- (match (find-packages-by-name name version)
+ (match (remove package-superseded
+ (find-packages-by-name name version))
(()
(leave (G_ "~a~@[@~a~]: package not found~%") name version))
(packages
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 54bbaddf30..04970cf503 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -19,6 +19,7 @@
(define-module (guix scripts pull)
#:use-module (guix ui)
+ #:use-module (guix colors)
#:use-module (guix utils)
#:use-module ((guix status) #:select (with-status-verbosity))
#:use-module (guix scripts)
@@ -38,7 +39,8 @@
#:use-module (guix git)
#:use-module (git)
#:use-module (gnu packages)
- #:use-module ((guix scripts package) #:select (build-and-use-profile))
+ #: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)
@@ -92,6 +94,14 @@ Download and deploy the latest version of Guix.\n"))
-l, --list-generations[=PATTERN]
list generations matching PATTERN"))
(display (G_ "
+ --roll-back roll back to the previous generation"))
+ (display (G_ "
+ -d, --delete-generations[=PATTERN]
+ delete generations matching PATTERN"))
+ (display (G_ "
+ -S, --switch-generation=PATTERN
+ switch to a generation matching PATTERN"))
+ (display (G_ "
-p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current"))
(display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL"))
@@ -120,6 +130,18 @@ Download and deploy the latest version of Guix.\n"))
(lambda (opt name arg result)
(cons `(query list-generations ,arg)
result)))
+ (option '("roll-back") #f #f
+ (lambda (opt name arg result)
+ (cons '(generation roll-back)
+ result)))
+ (option '(#\S "switch-generation") #t #f
+ (lambda (opt name arg result)
+ (cons `(generation switch ,arg)
+ result)))
+ (option '(#\d "delete-generations") #f #t
+ (lambda (opt name arg result)
+ (cons `(generation delete ,arg)
+ result)))
(option '(#\N "news") #f #f
(lambda (opt name arg result)
(cons '(query display-news) result)))
@@ -167,7 +189,7 @@ Download and deploy the latest version of Guix.\n"))
current-is-newer?)
"Display what's up in PROFILE--new packages, and all that. If
CURRENT-IS-NEWER? is true, assume that the current process represents the
-newest generation of PROFILE."
+newest generation of PROFILE. Return true when there's more info to display."
(match (memv (generation-number profile)
(reverse (profile-generations profile)))
((current previous _ ...)
@@ -190,7 +212,162 @@ newest generation of PROFILE."
#:concise? concise?
#:heading
(G_ "New in this revision:\n")))))
- (_ #t)))
+ (_ #f)))
+
+(define (display-channel channel)
+ "Display information about CHANNEL."
+ (format (current-error-port)
+ ;; TRANSLATORS: This describes a "channel"; the first placeholder is
+ ;; the channel name (e.g., "guix") and the second placeholder is its
+ ;; URL.
+ (G_ " ~a at ~a~%")
+ (channel-name channel)
+ (channel-url channel)))
+
+(define (channel=? channel1 channel2)
+ "Return true if CHANNEL1 and CHANNEL2 are the same for all practical
+purposes."
+ ;; Assume that the URL matters less than the name.
+ (eq? (channel-name channel1) (channel-name channel2)))
+
+(define (display-news-entry-title entry language port)
+ "Display the title of ENTRY, a news entry, to PORT."
+ (define title
+ (channel-news-entry-title entry))
+
+ (format port " ~a~%"
+ (highlight
+ (string-trim-right
+ (texi->plain-text (or (assoc-ref title language)
+ (assoc-ref title (%default-message-language))
+ ""))))))
+
+(define (display-news-entry entry language port)
+ "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to
+PORT."
+ (define body
+ (channel-news-entry-body entry))
+
+ (display-news-entry-title entry language port)
+ (format port (dim (G_ " commit ~a~%"))
+ (channel-news-entry-commit entry))
+ (newline port)
+ (format port " ~a~%"
+ (indented-string
+ (parameterize ((%text-width (- (%text-width) 4)))
+ (string-trim-right
+ (texi->plain-text (or (assoc-ref body language)
+ (assoc-ref body (%default-message-language))
+ ""))))
+ 4)))
+
+(define* (display-channel-specific-news new old
+ #:key (port (current-output-port))
+ concise?)
+ "Display channel news applicable the commits between OLD and NEW, where OLD
+and NEW are <channel> records with a proper 'commit' field. When CONCISE? is
+true, display nothing but the news titles. Return true if there are more news
+to display."
+ (let ((channel new)
+ (old (channel-commit old))
+ (new (channel-commit new)))
+ (when (and old new)
+ (let ((language (current-message-language)))
+ (match (channel-news-for-commit channel new old)
+ (() ;no news is good news
+ #f)
+ ((entries ...)
+ (newline port)
+ (format port (G_ "News for channel '~a'~%")
+ (channel-name channel))
+ (for-each (if concise?
+ (cut display-news-entry-title <> language port)
+ (cut display-news-entry <> language port))
+ entries)
+ (newline port)
+ #t))))))
+
+(define* (display-channel-news profile
+ #:optional
+ (previous
+ (and=> (relative-generation profile -1)
+ (cut generation-file-name profile <>))))
+ "Display news about the channels of PROFILE compared to PREVIOUS."
+ (when previous
+ (let ((old-channels (profile-channels previous))
+ (new-channels (profile-channels profile)))
+ (and (pair? old-channels) (pair? new-channels)
+ (begin
+ (match (lset-difference channel=? new-channels old-channels)
+ (()
+ #t)
+ (new
+ (let ((count (length new)))
+ (format (current-error-port)
+ (N_ " ~a new channel:~%"
+ " ~a new channels:~%" count)
+ count)
+ (for-each display-channel new))))
+ (match (lset-difference channel=? old-channels new-channels)
+ (()
+ #t)
+ (removed
+ (let ((count (length removed)))
+ (format (current-error-port)
+ (N_ " ~a channel removed:~%"
+ " ~a channels removed:~%" count)
+ count)
+ (for-each display-channel removed))))
+
+ ;; Display channel-specific news for those channels that were
+ ;; here before and are still around afterwards.
+ (for-each (match-lambda
+ ((new old)
+ (display-channel-specific-news new old)))
+ (filter-map (lambda (new)
+ (define old
+ (find (cut channel=? new <>)
+ old-channels))
+
+ (and old (list new old)))
+ new-channels)))))))
+
+(define* (display-channel-news-headlines profile)
+ "Display the titles of news about the channels of PROFILE compared to its
+previous generation. Return true if there are news to display."
+ (define previous
+ (and=> (relative-generation profile -1)
+ (cut generation-file-name profile <>)))
+
+ (when previous
+ (let ((old-channels (profile-channels previous))
+ (new-channels (profile-channels profile)))
+ ;; Find the channels present in both PROFILE and PREVIOUS, and print
+ ;; their news.
+ (and (pair? old-channels) (pair? new-channels)
+ (let ((channels (filter-map (lambda (new)
+ (define old
+ (find (cut channel=? new <>)
+ old-channels))
+
+ (and old (list new old)))
+ new-channels)))
+ (define more?
+ (map (match-lambda
+ ((new old)
+ (display-channel-specific-news new old
+ #:concise? #t)))
+ channels))
+
+ (any ->bool more?))))))
+
+(define (display-news profile)
+ ;; Display profile news, with the understanding that this process represents
+ ;; the newest generation.
+ (display-profile-news profile
+ #:current-is-newer? #t)
+
+ (display-channel-news profile))
(define* (build-and-install instances profile
#:key use-substitutes? verbose? dry-run?)
@@ -211,7 +388,12 @@ true, display what would be built without actually building it."
#:dry-run? dry-run?)
(munless dry-run?
(return (newline))
- (return (display-profile-news profile #:concise? #t))
+ (return
+ (let ((more? (list (display-profile-news profile #:concise? #t)
+ (display-channel-news-headlines profile))))
+ (when (any ->bool more?)
+ (display-hint
+ (G_ "Run @command{guix pull --news} to read all the news.")))))
(if guix-command
(let ((new (map (cut string-append <> "/bin/guix")
(list (user-friendly-profile profile)
@@ -293,8 +475,15 @@ true, display what would be built without actually building it."
;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move
;; them to %PROFILE-DIRECTORY.
- (unless (string=? %profile-directory
- (dirname (canonicalize-profile %user-profile-directory)))
+ ;;
+ ;; XXX: Ubuntu's 'sudo' preserves $HOME by default, and thus the second
+ ;; condition below is always false when one runs "sudo guix pull". As a
+ ;; workaround, skip this code when $SUDO_USER is set. See
+ ;; <https://bugs.gnu.org/36785>.
+ (unless (or (getenv "SUDO_USER")
+ (string=? %profile-directory
+ (dirname
+ (canonicalize-profile %user-profile-directory))))
(migrate-generations %user-profile-directory %profile-directory))
;; Make sure ~/.config/guix/current points to /var/guix/profiles/….
@@ -404,7 +593,9 @@ it."
"Given the two package name/version alists ALIST1 and ALIST2, display the
list of new and upgraded packages going from ALIST1 to ALIST2. When ALIST1
and ALIST2 differ, display HEADING upfront. When CONCISE? is true, do not
-display long package lists that would fill the user's screen."
+display long package lists that would fill the user's screen.
+
+Return true when there is more package info to display."
(define (pretty str column)
(indented-string (fill-paragraph str (- (%text-width) 4)
column)
@@ -447,11 +638,9 @@ display long package lists that would fill the user's screen."
(pretty (list->enumeration (sort upgraded string<?))
35))))
- (when (and concise?
- (or (> new-count concise/max-item-count)
- (> upgraded-count concise/max-item-count)))
- (display-hint (G_ "Run @command{guix pull --news} to view the complete
-list of package changes.")))))
+ (and concise?
+ (or (> new-count concise/max-item-count)
+ (> upgraded-count concise/max-item-count)))))
(define (display-profile-content-diff profile gen1 gen2)
"Display the changes in PROFILE GEN2 compared to generation GEN1."
@@ -475,6 +664,8 @@ list of package changes.")))))
((first second rest ...)
(display-profile-content-diff profile
first second)
+ (display-channel-news (generation-file-name profile second)
+ (generation-file-name profile first))
(loop (cons second rest)))
((_) #t)
(() #t))))))
@@ -493,10 +684,23 @@ list of package changes.")))))
((numbers ...)
(list-generations profile numbers)))))))
(('display-news)
- ;; Display profile news, with the understanding that this process
- ;; represents the newest generation.
- (display-profile-news profile
- #:current-is-newer? #t))))
+ (display-news profile))))
+
+(define (process-generation-change opts profile)
+ "Process a request to change the current generation (roll-back, switch, delete)."
+ (unless (assoc-ref opts 'dry-run?)
+ (match (assoc-ref opts 'generation)
+ (('roll-back)
+ (with-store store
+ (roll-back* store profile)))
+ (('switch pattern)
+ (let ((number (relative-generation-spec->number profile pattern)))
+ (if number
+ (switch-to-generation* profile number)
+ (leave (G_ "cannot switch to generation '~a'~%") pattern))))
+ (('delete pattern)
+ (with-store store
+ (delete-matching-generations store profile pattern))))))
(define (channel-list opts)
"Return the list of channels to use. If OPTS specify a channel file,
@@ -560,18 +764,18 @@ Use '~/.config/guix/channels.scm' instead."))
(with-git-error-handling
(let* ((opts (parse-command-line args %options
(list %default-options)))
- (cache (string-append (cache-directory) "/pull"))
(channels (channel-list opts))
(profile (or (assoc-ref opts 'profile) %current-profile)))
(cond ((assoc-ref opts 'query)
(process-query opts profile))
+ ((assoc-ref opts 'generation)
+ (process-generation-change opts profile))
(else
(with-store store
(ensure-default-profile)
(with-status-verbosity (assoc-ref opts 'verbosity)
(parameterize ((%current-system (assoc-ref opts 'system))
- (%graft? (assoc-ref opts 'graft?))
- (%repository-cache-directory cache))
+ (%graft? (assoc-ref opts 'graft?)))
(set-build-options-from-command-line store opts)
(honor-x509-certificates store)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index dd7026a6a4..daf6fcf947 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -285,10 +285,9 @@ update would trigger a complete rebuild."
(exit 0))
(define (warn-no-updater package)
- (format (current-error-port)
- (G_ "~a: warning: no updater for ~a~%")
- (location->string (package-location package))
- (package-name package)))
+ (warning (package-location package)
+ (G_ "no updater for ~a~%")
+ (package-name package)))
(define* (update-package store package updaters
#:key (key-download 'interactive) warn?)
@@ -306,11 +305,10 @@ warn about packages that have no matching updater."
(when version
(if (and=> tarball file-exists?)
(begin
- (format (current-error-port)
- (G_ "~a: ~a: updating from version ~a to version ~a...~%")
- (location->string loc)
- (package-name package)
- (package-version package) version)
+ (info loc
+ (G_ "~a: updating from version ~a to version ~a...~%")
+ (package-name package)
+ (package-version package) version)
(for-each
(lambda (change)
(format (current-error-port)
@@ -350,31 +348,36 @@ WARN? is true and no updater exists for PACKAGE, print a warning."
(case (version-compare (upstream-source-version source)
(package-version package))
((>)
- (format (current-error-port)
- (G_ "~a: ~a would be upgraded from ~a to ~a~%")
- (location->string loc)
- (package-name package) (package-version package)
- (upstream-source-version source)))
+ (info loc
+ (G_ "~a would be upgraded from ~a to ~a~%")
+ (package-name package) (package-version package)
+ (upstream-source-version source)))
((=)
(when warn?
- (format (current-error-port)
- (G_ "~a: info: ~a is already the latest version of ~a~%")
- (location->string loc)
- (package-version package)
- (package-name package))))
+ (info loc
+ (G_ "~a is already the latest version of ~a~%")
+ (package-version package)
+ (package-name package))))
(else
(when warn?
- (format (current-error-port)
- (G_ "~a: warning: ~a is greater than \
+ (warning loc
+ (G_ "~a is greater than \
the latest known version of ~a (~a)~%")
- (location->string loc)
- (package-version package)
- (package-name package)
- (upstream-source-version source)))))))
+ (package-version package)
+ (package-name package)
+ (upstream-source-version source)))))))
(#f
(when warn?
- (warn-no-updater package)))))
-
+ ;; Distinguish between "no updater" and "failing updater."
+ (match (lookup-updater package updaters)
+ ((? upstream-updater? updater)
+ (warning (package-location package)
+ (G_ "'~a' updater failed to determine available \
+releases for ~a~%")
+ (upstream-updater-name updater)
+ (package-name package)))
+ (#f
+ (warn-no-updater package)))))))
;;;
diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm
index 8fceb83668..827b2eb7a9 100644
--- a/guix/scripts/search.scm
+++ b/guix/scripts/search.scm
@@ -19,6 +19,8 @@
(define-module (guix scripts search)
#:use-module (guix ui)
#:use-module (guix scripts package)
+ #:use-module ((guix scripts build)
+ #:select (%standard-build-options))
#:use-module (guix scripts)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -36,6 +38,9 @@ This is an alias for 'guix package -s'.\n"))
(display (G_ "
-V, --version display version information and exit"))
(newline)
+ (display (G_ "
+ -L, --load-path=DIR prepend DIR to the package module search path"))
+ (newline)
(show-bug-report-information))
(define %options
@@ -46,7 +51,11 @@ This is an alias for 'guix package -s'.\n"))
(exit 0)))
(option '(#\V "version") #f #f
(lambda args
- (show-version-and-exit "guix search")))))
+ (show-version-and-exit "guix search")))
+
+ (find (lambda (option)
+ (member "load-path" (option-names option)))
+ %standard-build-options)))
(define (guix-search . args)
(define (handle-argument arg result)
diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm
new file mode 100644
index 0000000000..ef64b5755b
--- /dev/null
+++ b/guix/scripts/show.scm
@@ -0,0 +1,76 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Simon Tournier <zimon.toutoune@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 scripts show)
+ #:use-module (guix ui)
+ #:use-module (guix scripts package)
+ #:use-module ((guix scripts build)
+ #:select (%standard-build-options))
+ #:use-module (guix scripts)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-37)
+ #:export (guix-show))
+
+(define (show-help)
+ (display (G_ "Usage: guix show [OPTION] PACKAGE...
+Show details about PACKAGE."))
+ (display (G_"
+This is an alias for 'guix package --show='.\n"))
+ (newline)
+ (display (G_ "
+ -h, --help display this help and exit"))
+ (display (G_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (display (G_ "
+ -L, --load-path=DIR prepend DIR to the package module search path"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specification of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix show")))
+
+ (find (lambda (option)
+ (member "load-path" (option-names option)))
+ %standard-build-options)))
+
+(define (guix-show . args)
+ (define (handle-argument arg result)
+ ;; Treat all non-option arguments as regexps.
+ (cons `(query show ,arg)
+ result))
+
+ (define opts
+ (args-fold* args %options
+ (lambda (opt name arg . rest)
+ (leave (G_ "~A: unrecognized option~%") name))
+ handle-argument
+ '()))
+
+ (unless (assoc-ref opts 'query)
+ (leave (G_ "missing arguments: no package to show~%")))
+
+ (guix-package* opts))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9fc3a10e98..27b014db68 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -384,12 +384,14 @@ STORE is an open connection to the store."
(bootloader bootloader)))
;; Make the specified system generation the default entry.
- (params (profile-boot-parameters %system-profile (list number)))
+ (params (first (profile-boot-parameters %system-profile
+ (list number))))
(old-generations
(delv number (reverse (generation-numbers %system-profile))))
(old-params (profile-boot-parameters
%system-profile old-generations))
- (entries (map boot-parameters->menu-entry params))
+ (entries (cons (boot-parameters->menu-entry params)
+ (boot-parameters-bootloader-menu-entries params)))
(old-entries (map boot-parameters->menu-entry old-params)))
(run-with-store store
(mlet* %store-monad
diff --git a/guix/self.scm b/guix/self.scm
index f03fe01d0c..207e80d842 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -124,7 +124,11 @@ NODE's modules, under their FHS directories: share/guile/site and lib/guile."
(symlink #$(node-compiled node) object))))
(computed-file (string-append (node-name node) "-modules")
- build))
+ build
+ #:options '(#:local-build? #t
+
+ ;; "Building" it locally is faster.
+ #:substitutable? #f)))
(define (node-fold proc init nodes)
(let loop ((nodes nodes)
@@ -729,6 +733,7 @@ Info manual."
(filter-map (match-lambda
(('guix 'scripts _ ..1) #f)
(('guix 'man-db) #f)
+ (('guix 'tests _ ...) #f)
(name name))
(scheme-modules* source "guix"))
(list *core-modules*)
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ede00133c8..b6b55bdfcb 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -21,6 +21,7 @@
#:use-module (guix inferior)
#:use-module (guix i18n)
#:use-module ((guix utils) #:select (&fix-hint))
+ #:use-module (gcrypt pk-crypto)
#:use-module (ssh session)
#:use-module (ssh auth)
#:use-module (ssh key)
@@ -39,6 +40,8 @@
remote-inferior
remote-daemon-channel
connect-to-remote-daemon
+ remote-system
+ remote-authorize-signing-key
send-files
retrieve-files
retrieve-files*
@@ -97,16 +100,27 @@ specifies; otherwise use them. Throw an error on failure."
(message (format #f (G_ "SSH connection to '~a' failed: ~a~%")
host (get-error session))))))))))
-(define (remote-inferior session)
- "Return a remote inferior for the given SESSION."
- (let ((pipe (open-remote-pipe* session OPEN_BOTH
- "guix" "repl" "-t" "machine")))
+(define* (remote-inferior session #:optional become-command)
+ "Return a remote inferior for the given SESSION. If BECOME-COMMAND is
+given, use that to invoke the remote Guile REPL."
+ (let* ((repl-command (append (or become-command '())
+ '("guix" "repl" "-t" "machine")))
+ (pipe (apply open-remote-pipe* session OPEN_BOTH repl-command)))
+ (when (eof-object? (peek-char pipe))
+ (let ((status (channel-get-exit-status pipe)))
+ (close-port pipe)
+ (raise (condition
+ (&message
+ (message (format #f (G_ "remote command '~{~a~^ ~}' failed \
+with status ~a")
+ repl-command status)))))))
(port->inferior pipe)))
-(define (inferior-remote-eval exp session)
+(define* (inferior-remote-eval exp session #:optional become-command)
"Evaluate EXP in a new inferior running in SESSION, and close the inferior
-right away."
- (let ((inferior (remote-inferior session)))
+right away. If BECOME-COMMAND is given, use that to invoke the remote Guile
+REPL."
+ (let ((inferior (remote-inferior session become-command)))
(dynamic-wind
(const #t)
(lambda ()
@@ -282,6 +296,34 @@ be read. When RECURSIVE? is true, the closure of FILES is exported."
,(object->string
(object->string export))))))
+(define (remote-system session)
+ "Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of
+the machine on the other end of SESSION."
+ (inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
+ session))
+
+(define* (remote-authorize-signing-key key session #:optional become-command)
+ "Send KEY, a canonical sexp containing a public key, over SESSION and add it
+to the system ACL file if it has not yet been authorized."
+ (inferior-remote-eval
+ `(begin
+ (use-modules (guix build utils)
+ (guix pki)
+ (guix utils)
+ (gcrypt pk-crypto)
+ (srfi srfi-26))
+
+ (define acl (current-acl))
+ (define key (string->canonical-sexp ,(canonical-sexp->string key)))
+
+ (unless (authorized-key? key)
+ (let ((acl (public-keys->acl (cons key (acl->public-keys acl)))))
+ (mkdir-p (dirname %acl-file))
+ (with-atomic-file-output %acl-file
+ (cut write-acl acl <>)))))
+ session
+ become-command))
+
(define* (send-files local files remote
#:key
recursive?
diff --git a/guix/store/roots.scm b/guix/store/roots.scm
index 4f23ae34e8..58653507f8 100644
--- a/guix/store/roots.scm
+++ b/guix/store/roots.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,9 +26,13 @@
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 ftw)
+ #:use-module (rnrs io ports)
#:re-export (%gc-roots-directory)
#:export (gc-roots
- user-owned?))
+ user-owned?
+ busy-store-items))
;;; Commentary:
;;;
@@ -118,3 +122,124 @@ are user-controlled symlinks stored anywhere on the file system."
(= (stat:uid stat) uid))
(const #f)))
+
+
+;;;
+;;; Listing "busy" store items: those referenced by currently running
+;;; processes.
+;;;
+
+(define %proc-directory
+ ;; Mount point of Linuxish /proc file system.
+ "/proc")
+
+(define (proc-file-roots dir file)
+ "Return a one-element list containing the file pointed to by DIR/FILE,
+or the empty list."
+ (or (and=> (false-if-exception (readlink (string-append dir "/" file)))
+ list)
+ '()))
+
+(define proc-exe-roots (cut proc-file-roots <> "exe"))
+(define proc-cwd-roots (cut proc-file-roots <> "cwd"))
+
+(define (proc-fd-roots dir)
+ "Return the list of store files referenced by DIR, which is a
+/proc/XYZ directory."
+ (let ((dir (string-append dir "/fd")))
+ (filter-map (lambda (file)
+ (let ((target (false-if-exception
+ (readlink (string-append dir "/" file)))))
+ (and target
+ (string-prefix? "/" target)
+ target)))
+ (or (scandir dir string->number) '()))))
+
+(define (proc-maps-roots dir)
+ "Return the list of store files referenced by DIR, which is a
+/proc/XYZ directory."
+ (define %file-mapping-line
+ (make-regexp "^.*[[:blank:]]+/([^ ]+)$"))
+
+ (call-with-input-file (string-append dir "/maps")
+ (lambda (maps)
+ (let loop ((line (read-line maps))
+ (roots '()))
+ (cond ((eof-object? line)
+ roots)
+ ((regexp-exec %file-mapping-line line)
+ =>
+ (lambda (match)
+ (let ((file (string-append "/"
+ (match:substring match 1))))
+ (loop (read-line maps)
+ (cons file roots)))))
+ (else
+ (loop (read-line maps) roots)))))))
+
+(define (proc-environ-roots dir)
+ "Return the list of store files referenced by DIR/environ, where DIR is a
+/proc/XYZ directory."
+ (define split-on-nul
+ (cute string-tokenize <>
+ (char-set-complement (char-set #\nul))))
+
+ (define (rhs-file-names str)
+ (let ((equal (string-index str #\=)))
+ (if equal
+ (let* ((str (substring str (+ 1 equal)))
+ (rx (string-append (regexp-quote %store-directory)
+ "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+")))
+ (map match:substring (list-matches rx str)))
+ '())))
+
+ (define environ
+ (string-append dir "/environ"))
+
+ (append-map rhs-file-names
+ (split-on-nul
+ (call-with-input-file environ
+ get-string-all))))
+
+(define (referenced-files)
+ "Return the list of referenced store items."
+ (append-map (lambda (pid)
+ (let ((proc (string-append %proc-directory "/" pid)))
+ (catch 'system-error
+ (lambda ()
+ (append (proc-exe-roots proc)
+ (proc-cwd-roots proc)
+ (proc-fd-roots proc)
+ (proc-maps-roots proc)
+ (proc-environ-roots proc)))
+ (lambda args
+ (let ((err (system-error-errno args)))
+ (if (or (= ENOENT err) ;TOCTTOU race
+ (= ESRCH err) ;ditto
+ (= EACCES err)) ;not running as root
+ '()
+ (apply throw args)))))))
+ (scandir %proc-directory string->number
+ (lambda (a b)
+ (< (string->number a) (string->number b))))))
+
+(define canonicalize-store-item
+ (let* ((store (string-append %store-directory "/"))
+ (prefix (string-length store)))
+ (lambda (file)
+ "Return #f if FILE is not a store item; otherwise, return the store file
+name without any sub-directory components."
+ (and (string-prefix? store file)
+ (string-append store
+ (let ((base (string-drop file prefix)))
+ (match (string-index base #\/)
+ (#f base)
+ (slash (string-take base slash)))))))))
+
+(define (busy-store-items)
+ "Return the list of store items used by the currently running processes.
+
+This code should typically run as root; it allows the garbage collector to
+determine which store items must not be deleted."
+ (delete-duplicates
+ (filter-map canonicalize-store-item (referenced-files))))
diff --git a/guix/svn-download.scm b/guix/svn-download.scm
index 5c25437059..4139cbc2e2 100644
--- a/guix/svn-download.scm
+++ b/guix/svn-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
@@ -131,6 +131,9 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "svn-checkout") build
+ #:leaked-env-vars '("http_proxy" "https_proxy"
+ "LC_ALL" "LC_MESSAGES" "LANG"
+ "COLUMNS")
#:system system
#:hash-algo hash-algo
#:hash hash
diff --git a/guix/swh.scm b/guix/swh.scm
index df2a138f04..7acad05928 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -20,6 +20,8 @@
#:use-module (guix base16)
#:use-module (guix build utils)
#:use-module ((guix build syscalls) #:select (mkdtemp!))
+ #:use-module (web uri)
+ #:use-module (guix json)
#:use-module (web client)
#:use-module (web response)
#:use-module (json)
@@ -32,6 +34,9 @@
#:use-module (ice-9 popen)
#:use-module ((ice-9 ftw) #:select (scandir))
#:export (%swh-base-url
+ %allow-request?
+
+ request-rate-limit-reached?
origin?
origin-id
@@ -101,6 +106,8 @@
request-cooking
vault-fetch
+ commit-id?
+
swh-download))
;;; Commentary:
@@ -129,40 +136,6 @@
url
(string-append url "/")))
-(define-syntax-rule (define-json-reader json->record ctor spec ...)
- "Define JSON->RECORD as a procedure that converts a JSON representation,
-read from a port, string, or hash table, into a record created by CTOR and
-following SPEC, a series of field specifications."
- (define (json->record input)
- (let ((table (cond ((port? input)
- (json->scm input))
- ((string? input)
- (json-string->scm input))
- ((or (null? input) (pair? input))
- input))))
- (let-syntax ((extract-field (syntax-rules ()
- ((_ table (field key json->value))
- (json->value (assoc-ref table key)))
- ((_ table (field key))
- (assoc-ref table key))
- ((_ table (field))
- (assoc-ref table
- (symbol->string 'field))))))
- (ctor (extract-field table spec) ...)))))
-
-(define-syntax-rule (define-json-mapping rtd ctor pred json->record
- (field getter spec ...) ...)
- "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
-and define JSON->RECORD as a conversion from JSON to a record of this type."
- (begin
- (define-record-type rtd
- (ctor field ...)
- pred
- (field getter) ...)
-
- (define-json-reader json->record ctor
- (field spec ...) ...)))
-
(define %date-regexp
;; Match strings like "2014-11-17T22:09:38+01:00" or
;; "2018-09-30T23:20:07.815449+00:00"".
@@ -190,31 +163,77 @@ Software Heritage."
(ref 10))))))
str)) ;oops!
+(define string*
+ ;; Converts "string or #nil" coming from JSON to "string or #f".
+ (match-lambda
+ ((? string? str) str)
+ ((? null?) #f)))
+
+(define %allow-request?
+ ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true
+ ;; to keep going. This can be used to disallow a requests when
+ ;; 'request-rate-limit-reached?' returns true, for instance.
+ (make-parameter (const #t)))
+
+;; The time when the rate limit for "/origin/save" POST requests and that of
+;; other requests will be reset.
+;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
+(define %save-rate-limit-reset-time 0)
+(define %general-rate-limit-reset-time 0)
+
+(define (request-rate-limit-reached? url method)
+ "Return true if the rate limit has been reached for URI."
+ (define uri
+ (string->uri url))
+
+ (define reset-time
+ (if (and (eq? method http-post)
+ (string-prefix? "/api/1/origin/save/" (uri-path uri)))
+ %save-rate-limit-reset-time
+ %general-rate-limit-reset-time))
+
+ (< (car (gettimeofday)) reset-time))
+
+(define (update-rate-limit-reset-time! url method response)
+ "Update the rate limit reset time for URL and METHOD based on the headers in
+RESPONSE."
+ (let ((uri (string->uri url)))
+ (match (assq-ref (response-headers response) 'x-ratelimit-reset)
+ ((= string->number (? number? reset))
+ (if (and (eq? method http-post)
+ (string-prefix? "/api/1/origin/save/" (uri-path uri)))
+ (set! %save-rate-limit-reset-time reset)
+ (set! %general-rate-limit-reset-time reset)))
+ (_
+ #f))))
+
(define* (call url decode #:optional (method http-get)
#:key (false-if-404? #t))
"Invoke the endpoint at URL using METHOD. Decode the resulting JSON body
using DECODE, a one-argument procedure that takes an input port. When
FALSE-IF-404? is true, return #f upon 404 responses."
- (let*-values (((response port)
- (method url #:streaming? #t)))
- ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
- (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
- (#f #t)
- ((? (compose zero? string->number))
- (throw 'swh-error url response))
- (_ #t))
-
- (cond ((= 200 (response-code response))
- (let ((result (decode port)))
- (close-port port)
- result))
- ((and false-if-404?
- (= 404 (response-code response)))
- (close-port port)
- #f)
- (else
- (close-port port)
- (throw 'swh-error url response)))))
+ (and ((%allow-request?) url method)
+ (let*-values (((response port)
+ (method url #:streaming? #t)))
+ ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
+ (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
+ (#f #t)
+ ((? (compose zero? string->number))
+ (update-rate-limit-reset-time! url method response)
+ (throw 'swh-error url method response))
+ (_ #t))
+
+ (cond ((= 200 (response-code response))
+ (let ((result (decode port)))
+ (close-port port)
+ result))
+ ((and false-if-404?
+ (= 404 (response-code response)))
+ (close-port port)
+ #f)
+ (else
+ (close-port port)
+ (throw 'swh-error url method response))))))
(define-syntax define-query
(syntax-rules (path)
@@ -239,8 +258,8 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(date visit-date "date" string->date*)
(origin visit-origin)
(url visit-url "origin_visit_url")
- (snapshot-url visit-snapshot-url "snapshot_url")
- (status visit-status)
+ (snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f
+ (status visit-status "status" string->symbol) ;'full | 'partial | 'ongoing
(number visit-number "visit"))
;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/>
@@ -378,9 +397,11 @@ FALSE-IF-404? is true, return #f upon 404 responses."
(map json->visit (vector->list (json->scm port))))))
(define (visit-snapshot visit)
- "Return the snapshot corresponding to VISIT."
- (call (swh-url (visit-snapshot-url visit))
- json->snapshot))
+ "Return the snapshot corresponding to VISIT or #f if no snapshot is
+available."
+ (and (visit-snapshot-url visit)
+ (call (swh-url (visit-snapshot-url visit))
+ json->snapshot)))
(define (branch-target branch)
"Return the target of BRANCH, either a <revision> or a <release>."
@@ -396,7 +417,7 @@ FALSE-IF-404? is true, return #f upon 404 responses."
"Return a <revision> corresponding to the given TAG for the repository
coming from URL. Example:
- (lookup-origin-release \"https://github.com/guix-mirror/guix/\" \"v0.8\")
+ (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\")
=> #<<revision> id: \"44941…\" …>
The information is based on the latest visit of URL available. Return #f if
@@ -404,7 +425,7 @@ URL could not be found."
(match (lookup-origin url)
(#f #f)
(origin
- (match (origin-visits origin)
+ (match (filter visit-snapshot-url (origin-visits origin))
((visit . _)
(let ((snapshot (visit-snapshot visit)))
(match (and=> (find (lambda (branch)
@@ -516,7 +537,7 @@ requested bundle cooking, waiting for completion...~%"))
(define (commit-id? reference)
"Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
-it is a tag name."
+it is a tag name. This is based on a simple heuristic so use with care!"
(and (= (string-length reference) 40)
(string-every char-set:hex-digit reference)))
@@ -533,7 +554,8 @@ delete it when leaving the dynamic extent of this call."
(lambda ()
(false-if-exception (delete-file-recursively tmp-dir))))))
-(define (swh-download url reference output)
+(define* (swh-download url reference output
+ #:key (log-port (current-error-port)))
"Download from Software Heritage a checkout of the Git tag or commit
REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success
and #f on failure.
@@ -545,21 +567,31 @@ wait until it becomes available, which could take several minutes."
(lookup-revision reference)
(lookup-origin-revision url reference))
((? revision? revision)
+ (format log-port "SWH: found revision ~a with directory at '~a'~%"
+ (revision-id revision)
+ (swh-url (revision-directory-url revision)))
(call-with-temporary-directory
(lambda (directory)
- (let ((input (vault-fetch (revision-directory revision) 'directory))
- (tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
- (dump-port input tar)
- (close-port input)
- (let ((status (close-pipe tar)))
- (unless (zero? status)
- (error "tar extraction failure" status)))
-
- (match (scandir directory)
- (("." ".." sub-directory)
- (copy-recursively (string-append directory "/" sub-directory)
- output
- #:log (%make-void-port "w"))
- #t))))))
+ (match (vault-fetch (revision-directory revision) 'directory
+ #:log-port log-port)
+ (#f
+ (format log-port
+ "SWH: directory ~a could not be fetched from the vault~%"
+ (revision-directory revision))
+ #f)
+ ((? port? input)
+ (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
+ (dump-port input tar)
+ (close-port input)
+ (let ((status (close-pipe tar)))
+ (unless (zero? status)
+ (error "tar extraction failure" status)))
+
+ (match (scandir directory)
+ (("." ".." sub-directory)
+ (copy-recursively (string-append directory "/" sub-directory)
+ output
+ #:log (%make-void-port "w"))
+ #t))))))))
(#f
#f)))
diff --git a/guix/tests.scm b/guix/tests.scm
index 66d60e964e..ff31bcad44 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -23,12 +23,18 @@
#:use-module (guix packages)
#:use-module (guix base32)
#:use-module (guix serialization)
+ #:use-module (guix monads)
+ #:use-module ((guix utils) #:select (substitute-keyword-arguments))
+ #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module (gcrypt hash)
#:use-module (guix build-system gnu)
+ #:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
+ #:use-module (ice-9 match)
#:use-module (ice-9 binary-ports)
#:use-module (web uri)
#:export (open-connection-for-tests
@@ -42,6 +48,8 @@
shebang-too-long?
with-environment-variable
+ search-bootstrap-binary
+
mock
%test-substitute-urls
test-assertm
@@ -50,7 +58,9 @@
with-derivation-narinfo
with-derivation-substitute
dummy-package
- dummy-origin))
+ dummy-origin
+
+ gnu-make-for-tests))
;;; Commentary:
;;;
@@ -83,6 +93,35 @@
store)))
+(define (bootstrap-binary-file program system)
+ "Return the absolute file name where bootstrap binary PROGRAM for SYSTEM is
+stored."
+ (string-append (dirname (search-path %load-path
+ "gnu/packages/bootstrap.scm"))
+ "/bootstrap/" system "/" program))
+
+(define (search-bootstrap-binary file-name system)
+ "Search the bootstrap binary FILE-NAME for SYSTEM. Raise an error if not
+found."
+ ;; Note: Keep bootstrap binaries on the local file system so that the 'guix'
+ ;; package can provide them as inputs and copy them to the right place.
+ (let* ((system (match system
+ ("x86_64-linux" "i686-linux")
+ (_ system)))
+ (file (bootstrap-binary-file file-name system)))
+ (if (file-exists? file)
+ file
+ (with-store store
+ (run-with-store store
+ (mlet %store-monad ((drv (origin->derivation
+ (bootstrap-executable file-name system))))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (begin
+ (mkdir-p (dirname file))
+ (copy-file (derivation->output-path drv) file)
+ (return file)))))))))
+
(define (call-with-external-store proc)
"Call PROC with an open connection to the external store or #f it there is
no external store to talk to."
@@ -364,6 +403,33 @@ default values, and with EXTRA-FIELDS set as specified."
(sha256 (base32 (make-string 52 #\x))))))
(origin (inherit o) extra-fields ...)))
+(define gnu-make-for-tests
+ ;; This is a variant of 'gnu-make-boot0' that can be built with minimal
+ ;; resources.
+ (package-with-bootstrap-guile
+ (package
+ (inherit gnu-make)
+ (name "make-test-boot0")
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:implicit-inputs? #f
+ #:tests? #f ;cannot run "make check"
+ ,@(substitute-keyword-arguments (package-arguments gnu-make)
+ ((#:phases phases)
+ `(modify-phases ,phases
+ (replace 'build
+ (lambda _
+ (invoke "./build.sh")
+ #t))
+ (replace 'install
+ (lambda* (#:key outputs #:allow-other-keys)
+ (let* ((out (assoc-ref outputs "out"))
+ (bin (string-append out "/bin")))
+ (install-file "make" bin)
+ #t))))))))
+ (native-inputs '()) ;no need for 'pkg-config'
+ (inputs %bootstrap-inputs-for-tests))))
+
;; Local Variables:
;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
;; eval: (put 'call-with-derivation-substitute 'scheme-indent-function 2)
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
new file mode 100644
index 0000000000..21573ac14e
--- /dev/null
+++ b/guix/tests/git.scm
@@ -0,0 +1,105 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 tests git)
+ #:use-module (git)
+ #:use-module ((guix git) #:select (with-repository))
+ #:use-module (guix utils)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 control)
+ #:export (git-command
+ with-temporary-git-repository
+ find-commit))
+
+(define git-command
+ (make-parameter "git"))
+
+(define (populate-git-repository directory directives)
+ "Initialize a new Git checkout and repository in DIRECTORY and apply
+DIRECTIVES. Each element of DIRECTIVES is an sexp like:
+
+ (add \"foo.txt\" \"hi!\")
+
+Return DIRECTORY on success."
+
+ ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do
+ ;; all this, so resort to the "git" command.
+ (define (git command . args)
+ (apply invoke (git-command) "-C" directory
+ command args))
+
+ (mkdir-p directory)
+ (git "init")
+
+ (let loop ((directives directives))
+ (match directives
+ (()
+ directory)
+ ((('add file contents) rest ...)
+ (let ((file (string-append directory "/" file)))
+ (mkdir-p (dirname file))
+ (call-with-output-file file
+ (lambda (port)
+ (display (if (string? contents)
+ contents
+ (with-repository directory repository
+ (contents repository)))
+ port)))
+ (git "add" file)
+ (loop rest)))
+ ((('commit text) rest ...)
+ (git "commit" "-m" text)
+ (loop rest))
+ ((('tag name) rest ...)
+ (git "tag" name)
+ (loop rest))
+ ((('branch name) rest ...)
+ (git "branch" name)
+ (loop rest))
+ ((('checkout branch) rest ...)
+ (git "checkout" branch)
+ (loop rest))
+ ((('merge branch message) rest ...)
+ (git "merge" branch "-m" message)
+ (loop rest)))))
+
+(define (call-with-temporary-git-repository directives proc)
+ (call-with-temporary-directory
+ (lambda (directory)
+ (populate-git-repository directory directives)
+ (proc directory))))
+
+(define-syntax-rule (with-temporary-git-repository directory
+ directives exp ...)
+ "Evaluate EXP in a context where DIRECTORY contains a checkout populated as
+per DIRECTIVES."
+ (call-with-temporary-git-repository directives
+ (lambda (directory)
+ exp ...)))
+
+(define (find-commit repository message)
+ "Return the commit in REPOSITORY whose message includes MESSAGE, a string."
+ (let/ec return
+ (fold-commits (lambda (commit _)
+ (and (string-contains (commit-message commit)
+ message)
+ (return commit)))
+ #f
+ repository)
+ (error "commit not found" message)))
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index a56d6f213d..05ce39bca2 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +22,7 @@
#:use-module (web server http)
#:use-module (web response)
#:use-module (srfi srfi-39)
+ #:use-module (ice-9 match)
#:export (with-http-server
call-with-http-server
%http-server-port
@@ -69,10 +70,20 @@ needed."
(string-append "http://localhost:" (number->string (%http-server-port))
"/foo/bar"))
-(define* (call-with-http-server code data thunk
- #:key (headers '()))
- "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
+(define* (call-with-http-server responses+data thunk)
+ "Call THUNK with an HTTP server running and returning RESPONSES+DATA on HTTP
+requests. Each elements of RESPONSES+DATA must be a tuple containing a
+response and a string, or an HTTP response code and a string."
+ (define responses
+ (map (match-lambda
+ (((? response? response) data)
+ (list response data))
+ (((? integer? code) data)
+ (list (build-response #:code code
+ #:reason-phrase "Such is life")
+ data)))
+ responses+data))
+
(define (http-write server client response body)
"Write RESPONSE."
(let* ((response (write-response response client))
@@ -82,7 +93,8 @@ string) on HTTP requests."
(else
(write-response-body response body)))
(close-port port)
- (quit #t) ;exit the server thread
+ (when (null? responses)
+ (quit #t)) ;exit the server thread
(values)))
;; Mutex and condition variable to synchronize with the HTTP server.
@@ -105,10 +117,10 @@ string) on HTTP requests."
(define (server-body)
(define (handle request body)
- (values (build-response #:code code
- #:reason-phrase "Such is life"
- #:headers headers)
- data))
+ (match responses
+ (((response data) rest ...)
+ (set! responses rest)
+ (values response data))))
(let ((socket (open-http-server-socket)))
(catch 'quit
@@ -126,10 +138,7 @@ string) on HTTP requests."
(define-syntax with-http-server
(syntax-rules ()
- ((_ (code headers) data body ...)
- (call-with-http-server code data (lambda () body ...)
- #:headers headers))
- ((_ code data body ...)
- (call-with-http-server code data (lambda () body ...)))))
+ ((_ responses+data body ...)
+ (call-with-http-server responses+data (lambda () body ...)))))
;;; http.scm ends here
diff --git a/guix/ui.scm b/guix/ui.scm
index 7920335928..3e4bd5787e 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -13,6 +13,7 @@
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -120,6 +121,10 @@
roll-back*
switch-to-generation*
delete-generation*
+
+ %default-message-language
+ current-message-language
+
run-guix-command
run-guix
guix-main))
@@ -427,6 +432,20 @@ exiting. ARGS is the list of arguments received by the 'throw' handler."
report them in a user-friendly way."
(call-with-unbound-variable-handling (lambda () exp ...)))
+(define %default-message-language
+ ;; Default language to use for messages.
+ (make-parameter "en"))
+
+(define (current-message-language)
+ "Return the language used for messages according to the current locale.
+Return %DEFAULT-MESSAGE-LANGUAGE if that information could not be obtained. The
+result is an ISO-639-2 language code such as \"ar\", without the territory
+part."
+ (let ((locale (setlocale LC_MESSAGES)))
+ (match (string-index locale #\_)
+ (#f locale)
+ (index (string-take locale index)))))
+
(define (install-locale)
"Install the current locale settings."
(catch 'system-error
@@ -848,6 +867,17 @@ warning."
('profile-hook #t)
(_ #f)))
+(define (colorize-store-file-name file)
+ "Colorize FILE, a store file name, such that the hash part is less prominent
+that the rest."
+ (let ((len (string-length file))
+ (prefix (+ (string-length (%store-prefix)) 32 2)))
+ (if (< len prefix)
+ file
+ (string-append (colorize-string (string-take file prefix)
+ (color DARK))
+ (string-drop file prefix)))))
+
(define* (show-what-to-build store drv
#:key dry-run? (use-substitutes? #t)
(mode (build-mode normal)))
@@ -871,6 +901,11 @@ check and report what is prerequisites are available for download."
(substitution-oracle store inputs #:mode mode)
(const #f)))
+ (define colorized-store-item
+ (if (color-output? (current-error-port))
+ colorize-store-file-name
+ identity))
+
(let*-values (((build download)
(derivation-build-plan store inputs
#:mode mode
@@ -916,7 +951,7 @@ check and report what is prerequisites are available for download."
(N_ "~:[The following derivation would be built:~%~{ ~a~%~}~;~]"
"~:[The following derivations would be built:~%~{ ~a~%~}~;~]"
(length build))
- (null? build) build)
+ (null? build) (map colorized-store-item build))
(if display-download-size?
(format (current-error-port)
;; TRANSLATORS: "MB" is for "megabyte"; it should be
@@ -924,29 +959,31 @@ check and report what is prerequisites are available for download."
(G_ "~:[~,1h MB would be downloaded:~%~{ ~a~%~}~;~]")
(null? download)
download-size
- (map substitutable-path download))
+ (map (compose colorized-store-item substitutable-path)
+ download))
(format (current-error-port)
(N_ "~:[The following file would be downloaded:~%~{ ~a~%~}~;~]"
"~:[The following files would be downloaded:~%~{ ~a~%~}~;~]"
(length download))
(null? download)
- (map substitutable-path download)))
+ (map (compose colorized-store-item substitutable-path)
+ download)))
(format (current-error-port)
(N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]"
"~:[The following grafts would be made:~%~{ ~a~%~}~;~]"
(length graft))
- (null? graft) graft)
+ (null? graft) (map colorized-store-item graft))
(format (current-error-port)
(N_ "~:[The following profile hook would be built:~%~{ ~a~%~}~;~]"
"~:[The following profile hooks would be built:~%~{ ~a~%~}~;~]"
(length hook))
- (null? hook) hook))
+ (null? hook) (map colorized-store-item hook)))
(begin
(format (current-error-port)
(N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]"
"~:[The following derivations will be built:~%~{ ~a~%~}~;~]"
(length build))
- (null? build) build)
+ (null? build) (map colorized-store-item build))
(if display-download-size?
(format (current-error-port)
;; TRANSLATORS: "MB" is for "megabyte"; it should be
@@ -954,23 +991,25 @@ check and report what is prerequisites are available for download."
(G_ "~:[~,1h MB will be downloaded:~%~{ ~a~%~}~;~]")
(null? download)
download-size
- (map substitutable-path download))
+ (map (compose colorized-store-item substitutable-path)
+ download))
(format (current-error-port)
(N_ "~:[The following file will be downloaded:~%~{ ~a~%~}~;~]"
"~:[The following files will be downloaded:~%~{ ~a~%~}~;~]"
(length download))
(null? download)
- (map substitutable-path download)))
+ (map (compose colorized-store-item substitutable-path)
+ download)))
(format (current-error-port)
(N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]"
"~:[The following grafts will be made:~%~{ ~a~%~}~;~]"
(length graft))
- (null? graft) graft)
+ (null? graft) (map colorized-store-item graft))
(format (current-error-port)
(N_ "~:[The following profile hook will be built:~%~{ ~a~%~}~;~]"
"~:[The following profile hooks will be built:~%~{ ~a~%~}~;~]"
(length hook))
- (null? hook) hook)))
+ (null? hook) (map colorized-store-item hook))))
(check-available-space installed-size)
@@ -1281,33 +1320,32 @@ weight of this field in the final score.
A score of zero means that OBJ does not match any of REGEXPS. The higher the
score, the more relevant OBJ is to REGEXPS."
- (define (score str)
- (define scores
- (map (lambda (regexp)
- (fold-matches regexp str 0
- (lambda (m score)
- (+ score
- (if (string=? (match:substring m) str)
- 5 ;exact match
- 1)))))
- regexps))
-
+ (define (score regexp str)
+ (fold-matches regexp str 0
+ (lambda (m score)
+ (+ score
+ (if (string=? (match:substring m) str)
+ 5 ;exact match
+ 1)))))
+
+ (define (regexp->score regexp)
+ (let ((score-regexp (lambda (str) (score regexp str))))
+ (fold (lambda (metric relevance)
+ (match metric
+ ((field . weight)
+ (match (field obj)
+ (#f relevance)
+ ((? string? str)
+ (+ relevance (* (score-regexp str) weight)))
+ ((lst ...)
+ (+ relevance (* weight (apply + (map score-regexp lst)))))))))
+ 0 metrics)))
+
+ (let ((scores (map regexp->score regexps)))
;; Return zero if one of REGEXPS doesn't match.
(if (any zero? scores)
0
- (reduce + 0 scores)))
-
- (fold (lambda (metric relevance)
- (match metric
- ((field . weight)
- (match (field obj)
- (#f relevance)
- ((? string? str)
- (+ relevance (* (score str) weight)))
- ((lst ...)
- (+ relevance (* weight (apply + (map score lst)))))))))
- 0
- metrics))
+ (reduce + 0 scores))))
(define %package-metrics
;; Metrics used to compute the "relevance score" of a package against a set
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 1326b3db95..aa47dab4b4 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -245,18 +245,18 @@ correspond to the same version."
(define (lookup-updater package updaters)
"Return an updater among UPDATERS that matches PACKAGE, or #f if none of
them matches."
- (any (match-lambda
- (($ <upstream-updater> name description pred latest)
- (and (pred package) latest)))
- updaters))
+ (find (match-lambda
+ (($ <upstream-updater> name description pred latest)
+ (pred package)))
+ updaters))
(define (package-latest-release package updaters)
"Return an upstream source to update PACKAGE, a <package> object, or #f if
none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure
that the returned source is newer than the current one."
(match (lookup-updater package updaters)
- ((? procedure? latest-release)
- (latest-release package))
+ ((? upstream-updater? updater)
+ ((upstream-updater-latest updater) package))
(_ #f)))
(define (package-latest-release* package updaters)
@@ -362,6 +362,7 @@ SOURCE, an <upstream-source>."
(_
"gz")))
((url signature-url)
+ ;; Try to find a URL that matches ARCHIVE-TYPE.
(find2 (lambda (url sig-url)
;; Some URIs lack a file extension, like
;; 'https://crates.io/???/0.1/download'. In that
@@ -370,7 +371,13 @@ SOURCE, an <upstream-source>."
(string-suffix? archive-type url)))
urls
(or signature-urls (circular-list #f)))))
- (let ((tarball (download-tarball store url signature-url
+ ;; If none of URLS matches ARCHIVE-TYPE, then URL is #f; in that case,
+ ;; pick up the first element of URLS.
+ (let ((tarball (download-tarball store
+ (or url (first urls))
+ (and (pair? signature-urls)
+ (or signature-url
+ (first signature-urls)))
#:key-download key-download)))
(values version tarball source))))))
diff --git a/guix/utils.scm b/guix/utils.scm
index f480c3291f..1f99c5b3f5 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -91,6 +91,7 @@
arguments-from-environment-variable
file-extension
file-sans-extension
+ tarball-sans-extension
compressed-file?
switch-symlinks
call-with-temporary-output-file
@@ -578,6 +579,12 @@ minor version numbers from version-string."
(substring file 0 dot)
file)))
+(define (tarball-sans-extension tarball)
+ "Return TARBALL without its .tar.* or .zip extension."
+ (let ((end (or (string-contains tarball ".tar")
+ (string-contains tarball ".zip"))))
+ (substring tarball 0 end)))
+
(define (compressed-file? file)
"Return true if FILE denotes a compressed file."
(->bool (member (file-extension file)