diff options
Diffstat (limited to 'guix')
60 files changed, 2583 insertions, 1390 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 57e294d74d..af04084c86 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -172,7 +172,7 @@ set up using CL source package conventions." ;; Special considerations for source packages: CL inputs become ;; propagated, and un-handled arguments are removed. - (define new-propagated-inputs + (define (new-propagated-inputs) (if target-is-source? (map rewrite (append @@ -218,7 +218,7 @@ set up using CL source package conventions." (substitute-keyword-arguments base-arguments ((#:phases phases) (list phases-transformer phases)))) (inputs (new-inputs package-inputs)) - (propagated-inputs new-propagated-inputs) + (propagated-inputs (new-propagated-inputs)) (native-inputs (new-inputs package-native-inputs)) (outputs (if target-is-source? '("out") diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index da09cc7ded..5e76d64180 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -43,7 +43,7 @@ (define (default-scons) "Return the default SCons package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((python (resolve-interface '(gnu packages python)))) + (let ((python (resolve-interface '(gnu packages python-xyz)))) (module-ref python 'scons))) (define* (lower name diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 80882b144b..b6a86a1c62 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -39,9 +39,10 @@ ;; ;; Code: -;; These variables specify the SVN tag and the matching SVN revision. -(define %texlive-tag "texlive-2017.1") -(define %texlive-revision 44591) +;; These variables specify the SVN tag and the matching SVN revision. They +;; are taken from https://www.tug.org/svn/texlive/tags/ +(define %texlive-tag "texlive-2018.2") +(define %texlive-revision 49435) (define (texlive-ref component id) "Return a <svn-reference> object for the package ID, which is part of the diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 5a1363556a..9e31be93ff 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -26,28 +26,22 @@ #:use-module (system base message) #:use-module (guix modules) #:use-module (guix build utils) + #:use-module (language tree-il optimize) + #:use-module (language cps optimize) #:export (%default-optimizations %lightweight-optimizations compile-files)) ;;; Commentary: ;;; -;;; Support code to compile Guile code as efficiently as possible (both with -;;; Guile 2.0 and 2.2). +;;; Support code to compile Guile code as efficiently as possible (with 2.2). ;;; ;;; Code: -(cond-expand - (guile-2.2 (use-modules (language tree-il optimize) - (language cps optimize))) - (else #f)) - (define %default-optimizations ;; Default optimization options (equivalent to -O2 on Guile 2.2). - (cond-expand - (guile-2.2 (append (tree-il-default-optimization-options) - (cps-default-optimization-options))) - (else '()))) + (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) (define %lightweight-optimizations ;; Lightweight optimizations (like -O0, but with partial evaluation). @@ -103,8 +97,7 @@ (report-load file total completed) (format debug-port "~%loading '~a'...~%" file) - (parameterize ((current-warning-port debug-port)) - (resolve-interface (file-name->module-name file))) + (resolve-interface (file-name->module-name file)) (loop files (+ 1 completed))))))) @@ -164,37 +157,38 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." ;; Exit as soon as something goes wrong. (exit-on-exception - (with-fluids ((*current-warning-prefix* "")) - (with-target host - (lambda () - (let ((relative (relative-file source-directory file))) - (compile-file file - #:output-file (string-append build-directory "/" - (scm->go relative)) - #:opts (append warning-options - (optimization-options relative)))))))) + (with-target host + (lambda () + (let ((relative (relative-file source-directory file))) + (compile-file file + #:output-file (string-append build-directory "/" + (scm->go relative)) + #:opts (append warning-options + (optimization-options relative))))))) (with-mutex progress-lock (set! completed (+ 1 completed)))) (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory - ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all - ;; of FILES. - (load-files source-directory files - #:report-load report-load - #:debug-port debug-port) - - ;; Make sure compilation related modules are loaded before starting to - ;; compile files in parallel. - (compile #f) - - ;; XXX: Don't use too many workers to work around the insane memory - ;; requirements of the compiler in Guile 2.2.2: - ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>. - (n-par-for-each (min workers 8) build files) - - (unless (zero? total) - (report-compilation #f total total))))) + (with-fluids ((*current-warning-prefix* "")) + + ;; FIXME: To work around <https://bugs.gnu.org/15602>, we first load all + ;; of FILES. + (load-files source-directory files + #:report-load report-load + #:debug-port debug-port) + + ;; Make sure compilation related modules are loaded before starting to + ;; compile files in parallel. + (compile #f) + + ;; XXX: Don't use too many workers to work around the insane memory + ;; requirements of the compiler in Guile 2.2.2: + ;; <https://lists.gnu.org/archive/html/guile-devel/2017-05/msg00033.html>. + (n-par-for-each (min workers 8) build files) + + (unless (zero? total) + (report-compilation #f total total)))))) (eval-when (eval load) (when (and (string=? "2" (major-version)) diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm index 13f01fb1e8..681f22238d 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.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. ;;; @@ -93,8 +93,8 @@ ITEM." "Download and extract the normalized archive for ITEM. Return #t on success, #f otherwise." ;; Let progress reports go through. - (setvbuf (current-error-port) _IONBF) - (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) 'none) + (setvbuf (current-output-port) 'none) (let loop ((urls (urls-for-item item))) (match urls diff --git a/guix/build/download.scm b/guix/build/download.scm index 54163849a2..c08221b3b2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.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 © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; @@ -314,9 +314,7 @@ host name without trailing dot." ;; Write HTTP requests line by line rather than byte by byte: ;; <https://bugs.gnu.org/22966>. This is possible with Guile >= 2.2. - (cond-expand - (guile-2.2 (setvbuf record 'line)) - (else #f)) + (setvbuf record 'line) record))) @@ -359,7 +357,7 @@ ETIMEDOUT error is raised." (connect* s (addrinfo:addr ai) timeout) ;; Buffer input and output on this port. - (setvbuf s _IOFBF) + (setvbuf s 'block) ;; If we're using a proxy, make a note of that. (when http-proxy (set-http-proxy-port?! s #t)) s) @@ -403,7 +401,7 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (with-https-proxy (let ((s (open-socket-for-uri uri #:timeout timeout))) ;; Buffer input and output on this port. - (setvbuf s _IOFBF %http-receive-buffer-size) + (setvbuf s 'block %http-receive-buffer-size) (if https? (tls-wrap s (uri-host uri) @@ -506,18 +504,6 @@ port if PORT is a TLS session record port." (module-set! (resolve-module '(web http)) 'parse-rfc-822-date parse-rfc-822-date)) -;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile -;; up to 2.0.11. -(unless (or (> (string->number (major-version)) 2) - (> (string->number (minor-version)) 0) - (> (string->number (micro-version)) 11)) - (let ((var (module-variable (resolve-module '(web http)) - 'declare-relative-uri-header!))) - ;; If 'declare-relative-uri-header!' doesn't exist, forget it. - (when (and var (variable-bound? var)) - (let ((declare-relative-uri-header! (variable-ref var))) - (declare-relative-uri-header! "Location"))))) - ;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in ;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and ;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. See bug report at @@ -791,11 +777,11 @@ otherwise simply ignore them." hashes)) content-addressed-mirrors)) - ;; Make this unbuffered so 'progress-report/file' works as expected. _IOLBF + ;; Make this unbuffered so 'progress-report/file' works as expected. 'line ;; means '\n', not '\r', so it's not appropriate here. - (setvbuf (current-output-port) _IONBF) + (setvbuf (current-output-port) 'none) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-error-port) 'line) (let try ((uri (append uri content-addressed-uris))) (match uri diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index fcc2d6567d..00b0c7c406 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2019 Gabriel Hondet <gabrielhondet@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,7 +50,8 @@ "Install the given package." (let ((out (assoc-ref outputs "out")) (program (if jbuild? "jbuilder" "dune"))) - (invoke program install-target "--prefix" out)) + (invoke program install-target "--prefix" out "--libdir" + (string-append out "/lib/ocaml/site-lib"))) #t) (define %standard-phases diff --git a/guix/build/git.scm b/guix/build/git.scm index 2d1700a9b9..669e38cd32 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,8 @@ (define-module (guix build git) #:use-module (guix build utils) + #:use-module (srfi srfi-34) + #:use-module (ice-9 format) #:export (git-fetch)) ;;; Commentary: @@ -39,31 +41,39 @@ recursively. Return #t on success, #f otherwise." (mkdir-p directory) - (with-directory-excursion directory - (invoke git-command "init") - (invoke git-command "remote" "add" "origin" url) - (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) - (invoke git-command "checkout" "FETCH_HEAD") - (begin - (setvbuf (current-output-port) 'line) - (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") - (invoke git-command "fetch" "origin") - (invoke git-command "checkout" commit))) - (when recursive? - ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" - "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (guard (c ((invoke-error? c) + (format (current-error-port) + "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%" + (invoke-error-program c) + (invoke-error-arguments c) + (or (invoke-error-exit-status c) ;XXX: not quite accurate + (invoke-error-stop-signal c) + (invoke-error-term-signal c))) + (delete-file-recursively directory) + #f)) + (with-directory-excursion directory + (invoke git-command "init") + (invoke git-command "remote" "add" "origin" url) + (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) + (invoke git-command "checkout" "FETCH_HEAD") + (begin + (setvbuf (current-output-port) 'line) + (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") + (invoke git-command "fetch" "origin") + (invoke git-command "checkout" commit))) + (when recursive? + ;; Now is the time to fetch sub-modules. + (invoke git-command "submodule" "update" "--init" "--recursive") - ;; In sub-modules, '.git' is a flat file, not a directory, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) ;; The contents of '.git' vary as a function of the current ;; status of the Git repo. Since we want a fixed output, this ;; directory needs to be taken out. (delete-file-recursively ".git") - #t)) + #t))) ;;; git.scm ends here diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 0c7b4ac6fd..e5ef1d6d2b 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -101,7 +101,7 @@ when producing a bootstrap libc." util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ _nonshared\\.a)$") - (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-output-port) 'line) (let* ((libdir (string-append output "/lib"))) (mkdir-p libdir) (for-each (lambda (file) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 0c23cd300e..1dc7976879 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,8 +67,14 @@ user-friendly name of the profile is, for instance ~/.guix-profile rather than (define (build-etc/profile output search-paths) "Build the 'OUTPUT/etc/profile' shell file containing environment variable definitions for all the SEARCH-PATHS." - (mkdir-p (string-append output "/etc")) - (call-with-output-file (string-append output "/etc/profile") + (define file + (string-append output "/etc/profile")) + + (mkdir-p (dirname file)) + (when (file-exists? file) + (delete-file file)) + + (call-with-output-file file (lambda (port) ;; The use of $GUIX_PROFILE described below is not great. Another ;; option would have been to use "$1" and have users run: @@ -144,13 +150,22 @@ instead make DIRECTORY a \"real\" directory containing symlinks." create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for -all the variables listed in SEARCH-PATHS." + (define manifest-file + (string-append output "/manifest")) + ;; Make the symlinks. (union-build output inputs #:symlink symlink #:log-port (%make-void-port "w")) + ;; If one of the INPUTS provides a '/manifest' file, delete it. That can + ;; happen if MANIFEST contains something such as a Guix instance, which is + ;; ultimately built as a profile. + (when (file-exists? manifest-file) + (delete-file manifest-file)) + ;; Store meta-data. - (call-with-output-file (string-append output "/manifest") + (call-with-output-file manifest-file (lambda (p) (pretty-print manifest p))) diff --git a/guix/build/pull.scm b/guix/build/pull.scm deleted file mode 100644 index a011e366f6..0000000000 --- a/guix/build/pull.scm +++ /dev/null @@ -1,154 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (guix build pull) - #:use-module (guix modules) - #:use-module (guix build utils) - #:use-module (guix build compile) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:export (build-guix)) - -;;; Commentary: -;;; -;;; Helpers for the 'guix pull' command to unpack and build Guix. -;;; -;;; Code: - -(define (has-all-its-dependencies? file) - "Return true if the dependencies of the module defined in FILE are -available, false otherwise." - (let ((module (call-with-input-file file - (lambda (port) - (match (read port) - (('define-module name _ ...) - name)))))) - ;; If one of the dependencies of MODULE is missing, we get a - ;; '&missing-dependency-error'. - (guard (c ((missing-dependency-error? c) #f)) - (source-module-closure (list module) #:select? (const #t))))) - -(define (all-scheme-files directory) - "Return a sorted list of Scheme files found in DIRECTORY." - ;; Load guix/ modules before gnu/ modules to get somewhat steadier - ;; progress reporting. - (sort (filter (cut string-suffix? ".scm" <>) - (find-files directory "\\.scm")) - (let ((guix (string-append directory "/guix")) - (gnu (string-append directory "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (string<? a b)))))) - - -(define* (build-guix out source - #:key - system - storedir localstatedir sysconfdir sbindir - - (package-name "GNU Guix") - (package-version "0") - (bug-report-address "bug-guix@gnu.org") - (home-page-url "https://gnu.org/s/guix") - - libgcrypt zlib gzip bzip2 xz - - (debug-port (%make-void-port "w")) - (log-port (current-error-port))) - "Build and install Guix in directory OUT using SOURCE, a directory -containing the source code. Write any debugging output to DEBUG-PORT." - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) - - (with-directory-excursion source - (format #t "copying and compiling to '~a' with Guile ~a...~%" - out (version)) - - ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm. - (copy-recursively "guix" (string-append out "/guix") - #:log debug-port) - (copy-recursively "gnu" (string-append out "/gnu") - #:log debug-port) - (copy-file "guix.scm" (string-append out "/guix.scm")) - (copy-file "gnu.scm" (string-append out "/gnu.scm")) - - ;; Instantiate a (guix config) module that preserves the original - ;; settings. - (copy-file "guix/config.scm.in" - (string-append out "/guix/config.scm")) - (substitute* (string-append out "/guix/config.scm") - (("@PACKAGE_NAME@") package-name) - (("@PACKAGE_VERSION@") package-version) - (("@PACKAGE_BUGREPORT@") bug-report-address) - (("@PACKAGE_URL@") home-page-url) - (("@storedir@") storedir) - (("@guix_localstatedir@") localstatedir) - (("@guix_sysconfdir@") sysconfdir) - (("@guix_sbindir@") sbindir) - (("@guix_system@") system) - (("@LIBGCRYPT@") (string-append libgcrypt "/lib/libgcrypt")) - (("@LIBZ@") (string-append zlib "/lib/libz")) - (("@GZIP@") (string-append gzip "/bin/gzip")) - (("@BZIP2@") (string-append bzip2 "/bin/bzip2")) - (("@XZ@") (string-append xz "/bin/xz")) - (("@NIX_INSTANTIATE@") "nix-instantiate")) ;for (guix import nix) - - ;; Augment the search path so Scheme code can be compiled. - (set! %load-path (cons out %load-path)) - (set! %load-compiled-path (cons out %load-compiled-path)) - - ;; Compile the .scm files. Hide warnings. - (parameterize ((current-warning-port (%make-void-port "w"))) - ;; Filter out files depending on Guile-SSH when Guile-SSH is missing. - (let ((files (filter has-all-its-dependencies? - (all-scheme-files out)))) - (compile-files out out files - - #:workers (parallel-job-count) - - ;; Disable warnings. - #:warning-options '() - - #:report-load - (lambda (file total completed) - (display #\cr log-port) - (format log-port - "loading...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (format debug-port "~%loading '~a'...~%" file)) - - #:report-compilation - (lambda (file total completed) - (display #\cr log-port) - (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (format debug-port "~%compiling '~a'...~%" file)))))) - - (newline) - #t) - -;;; pull.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 56a689f667..66d63a2931 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -73,6 +73,7 @@ file-system-mount-flags statfs free-disk-space + device-in-use? processes mkdtemp! @@ -684,6 +685,32 @@ mounted at FILE." (define AT_NO_AUTOMOUNT #x800) (define AT_EMPTY_PATH #x1000) +(define-syntax BLKRRPART ;<sys/mount.h> + (identifier-syntax #x125F)) + +(define* (device-in-use? device) + "Return #t if the block DEVICE is in use, #f otherwise. This is inspired +from fdisk_device_is_used function of util-linux. This is particulary useful +for devices that do not appear in /proc/self/mounts like overlayfs lowerdir +backend device." + (let*-values (((fd) (open-fdes device O_RDONLY)) + ((ret err) (%ioctl fd BLKRRPART %null-pointer))) + (close-fdes fd) + (cond + ((= ret 0) + #f) + ((= err EBUSY) + #t) + ((= err EINVAL) + ;; We get EINVAL for devices that have the GENHD_FL_NO_PART_SCAN flag + ;; set in the kernel, in particular loopback devices, though we do seem + ;; to get it for SCSI storage (/dev/sr0) on QEMU. + #f) + (else + (throw 'system-error "ioctl" "~A" + (list (strerror err)) + (list err)))))) + ;;; ;;; Containers. @@ -699,39 +726,31 @@ mounted at FILE." (define CLONE_NEWPID #x20000000) (define CLONE_NEWNET #x40000000) -(cond-expand - (guile-2.2 - (define %set-automatic-finalization-enabled?! - ;; When using a statically-linked Guile, for instance in the initrd, we - ;; cannot resolve this symbol, but most of the time we don't need it - ;; anyway. Thus, delay it. - (let ((proc (delay - (pointer->procedure int - (dynamic-func - "scm_set_automatic_finalization_enabled" - (dynamic-link)) - (list int))))) - (lambda (enabled?) - "Switch on or off automatic finalization in a separate thread. +(define %set-automatic-finalization-enabled?! + ;; When using a statically-linked Guile, for instance in the initrd, we + ;; cannot resolve this symbol, but most of the time we don't need it + ;; anyway. Thus, delay it. + (let ((proc (delay + (pointer->procedure int + (dynamic-func + "scm_set_automatic_finalization_enabled" + (dynamic-link)) + (list int))))) + (lambda (enabled?) + "Switch on or off automatic finalization in a separate thread. Turning finalization off shuts down the finalization thread as a side effect." - (->bool ((force proc) (if enabled? 1 0)))))) - - (define-syntax-rule (without-automatic-finalization exp) - "Turn off automatic finalization within the dynamic extent of EXP." - (let ((enabled? #t)) - (dynamic-wind - (lambda () - (set! enabled? (%set-automatic-finalization-enabled?! #f))) - (lambda () - exp) - (lambda () - (%set-automatic-finalization-enabled?! enabled?)))))) - - (else - (define-syntax-rule (without-automatic-finalization exp) - ;; Nothing to do here: Guile 2.0 does not have a separate finalization - ;; thread. - exp))) + (->bool ((force proc) (if enabled? 1 0)))))) + +(define-syntax-rule (without-automatic-finalization exp) + "Turn off automatic finalization within the dynamic extent of EXP." + (let ((enabled? #t)) + (dynamic-wind + (lambda () + (set! enabled? (%set-automatic-finalization-enabled?! #f))) + (lambda () + exp) + (lambda () + (%set-automatic-finalization-enabled?! enabled?))))) ;; The libc interface to sys_clone is not useful for Scheme programs, so the ;; low-level system call is wrapped instead. The 'syscall' function is diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index 1c393ecd9d..841c631dae 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -35,7 +35,7 @@ (define (compile-with-latex format file) (invoke format - "-interaction=batchmode" + "-interaction=nonstopmode" "-output-directory=build" (string-append "&" format) file)) @@ -60,7 +60,12 @@ (("^TEXMF = .*") "TEXMF = $TEXMFROOT/share/texmf-dist\n")) (setenv "TEXMFCNF" (dirname texmf.cnf)) - (setenv "TEXMF" (string-append out "/share/texmf-dist"))) + (setenv "TEXMF" (string-append out "/share/texmf-dist")) + + ;; Don't truncate lines. + (setenv "error_line" "254") ; must be less than 255 + (setenv "half_error_line" "238") ; must be less than error_line - 15 + (setenv "max_print_line" "1000")) (mkdir "build") #t) diff --git a/guix/build/union.scm b/guix/build/union.scm index fff795c4d3..961ac3298b 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; @@ -39,6 +39,19 @@ ;;; ;;; Code: +;; This code can be used with the bootstrap Guile, which 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)) + rest))) + (else #f)) + (define (files-in-directory dirname) (let ((dir (opendir dirname))) (let loop ((files '())) @@ -179,10 +192,10 @@ returns #f, skip the faulty file altogether." (reverse dirs-with-file)))) table))) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) (when (file-port? log-port) - (setvbuf log-port _IOLBF)) + (setvbuf log-port 'line)) (union-of-directories output (delete-duplicates inputs))) diff --git a/guix/channels.scm b/guix/channels.scm index 75503bb0ae..96d62ce062 100644 --- a/guix/channels.scm +++ b/guix/channels.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> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -21,18 +21,28 @@ #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix combinators) + #:use-module (guix deprecation) #:use-module (guix store) #:use-module (guix i18n) + #:use-module ((guix utils) + #:select (source-properties->location + &error-location)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) - #:autoload (guix self) (whole-package) + #: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) #:export (channel channel? channel-name @@ -52,6 +62,7 @@ checkout->channel-instance latest-channel-derivation channel-instances->manifest + %channel-profile-hooks channel-instances->derivation)) ;;; Commentary: @@ -153,44 +164,43 @@ of previously processed channels." (or (channel-commit b) (not (or (channel-commit a) (channel-commit b)))))))) + ;; Accumulate a list of instances. A list of processed channels is also ;; accumulated to decide on duplicate channel specifications. - (match (fold (lambda (channel acc) - (match acc - ((#:channels previous-channels #:instances instances) - (if (ignore? channel previous-channels) - acc - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let-values (((checkout commit) - (latest-repository-commit store (channel-url channel) - #:ref (channel-reference - channel)))) - (let ((instance (channel-instance channel commit checkout))) - (let-values (((new-instances new-channels) - (latest-channel-instances - store - (channel-instance-dependencies instance) - previous-channels))) - `(#:channels - ,(append (cons channel new-channels) - previous-channels) - #:instances - ,(append (cons instance new-instances) - instances)))))))))) - `(#:channels ,previous-channels #:instances ()) - channels) - ((#:channels channels #:instances instances) - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - channels))))) + (define-values (resulting-channels instances) + (fold2 (lambda (channel previous-channels instances) + (if (ignore? channel previous-channels) + (values previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let-values (((checkout commit) + (latest-repository-commit store (channel-url channel) + #:ref (channel-reference + channel)))) + (let ((instance (channel-instance channel commit checkout))) + (let-values (((new-instances new-channels) + (latest-channel-instances + store + (channel-instance-dependencies instance) + previous-channels))) + (values (append (cons channel new-channels) + previous-channels) + (append (cons instance new-instances) + instances)))))))) + previous-channels + '() ;instances + channels)) + + (let ((instance-name (compose channel-name channel-instance-channel))) + ;; Remove all earlier channel specifications if they are followed by a + ;; more specific one. + (values (delete-duplicates instances + (lambda (a b) + (eq? (instance-name a) (instance-name b)))) + resulting-channels))) (define* (checkout->channel-instance checkout #:key commit @@ -214,45 +224,48 @@ of COMMIT at URL. Use NAME as the channel name." ;; place a set of compiled Guile modules in ~/.config/guix/latest. 1) -(define (standard-module-derivation name source dependencies) - "Return a derivation that builds the Scheme modules in SOURCE and that -depend on DEPENDENCIES, a list of lowerable objects. The assumption is that -SOURCE contains package modules to be added to '%package-module-path'." - (define modules - (scheme-modules* source)) - +(define (standard-module-derivation name source core dependencies) + "Return a derivation that builds with CORE, a Guix instance, the Scheme +modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable +objects. The assumption is that SOURCE contains package modules to be added +to '%package-module-path'." ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow ;; channel publishers to specify things such as the sub-directory where .scm ;; files live, files to exclude from the channel, preferred substitute URLs, ;; etc. - (mlet* %store-monad ((compiled - (compiled-modules modules - #:name name - #:module-path (list source) - #:extensions dependencies))) - - (gexp->derivation name - (with-extensions dependencies - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (let ((go (string-append #$output "/lib/guile/" - (effective-version) - "/site-ccache")) - (scm (string-append #$output - "/share/guile/site/" - (effective-version)))) - (mkdir-p (dirname go)) - (symlink #$compiled go) - (mkdir-p (dirname scm)) - (symlink #$source scm)))))))) + + (define build + ;; This is code that we'll run in CORE, a Guix instance, with its own + ;; modules and so on. That way, we make sure these modules are built for + ;; the right Guile version, with the right dependencies, and that they get + ;; to see the right (gnu packages …) modules. + (with-extensions dependencies + #~(begin + (use-modules (guix build compile) + (guix build utils) + (srfi srfi-26)) + + (define go + (string-append #$output "/lib/guile/" (effective-version) + "/site-ccache")) + (define scm + (string-append #$output "/share/guile/site/" + (effective-version))) + + (compile-files #$source go + (find-files #$source "\\.scm$")) + (mkdir-p (dirname scm)) + (symlink #$source scm) + scm))) + + (gexp->derivation-in-inferior name build core)) (define* (build-from-source name source - #:key verbose? commit + #:key core verbose? commit (dependencies '())) "Return a derivation to build Guix from SOURCE, using the self-build script -contained therein. Use COMMIT as the version string." +contained therein; use COMMIT as the version string. When CORE is true, build +package modules under SOURCE using CORE, an instance of Guix." ;; Running the self-build script makes it easier to update the build ;; procedure: the self-build script of the Guix-to-be-installed contains the ;; right dependencies, build procedure, etc., which the Guix-in-use may not @@ -263,7 +276,12 @@ contained therein. Use COMMIT as the version string." (if (file-exists? script) (let ((build (save-module-excursion (lambda () - (primitive-load script))))) + ;; Disable deprecation warnings; it's OK for SCRIPT to + ;; use deprecated APIs and the user doesn't have to know + ;; about it. + (parameterize ((deprecation-warning-port + (%make-void-port "w"))) + (primitive-load script)))))) ;; BUILD must be a monadic procedure of at least one argument: the ;; source tree. ;; @@ -274,9 +292,10 @@ contained therein. Use COMMIT as the version string." #:pull-version %pull-version)) ;; Build a set of modules that extend Guix using the standard method. - (standard-module-derivation name source dependencies))) + (standard-module-derivation name source core dependencies))) -(define* (build-channel-instance instance #:optional (dependencies '())) +(define* (build-channel-instance instance + #:optional core (dependencies '())) "Return, as a monadic value, the derivation for INSTANCE, a channel instance. DEPENDENCIES is a list of extensions providing Guile modules that INSTANCE depends on." @@ -284,8 +303,37 @@ INSTANCE depends on." (channel-name (channel-instance-channel instance))) (channel-instance-checkout instance) #:commit (channel-instance-commit instance) + #:core core #:dependencies dependencies)) +(define (resolve-dependencies instances) + "Return a procedure that, given one of the elements of INSTANCES, returns +list of instances it depends on." + (define channel-instance-name + (compose channel-name channel-instance-channel)) + + (define table ;map a name to an instance + (fold (lambda (instance table) + (vhash-consq (channel-instance-name instance) + instance table)) + vlist-null + instances)) + + (define edges + (fold (lambda (instance edges) + (fold (lambda (channel edges) + (let ((name (channel-name channel))) + (match (vhash-assq name table) + ((_ . target) + (vhash-consq instance target edges))))) + edges + (channel-instance-dependencies instance))) + vlist-null + instances)) + + (lambda (instance) + (vhash-foldq* cons '() instance edges))) + (define (channel-instance-derivations instances) "Return the list of derivations to build INSTANCES, in the same order as INSTANCES." @@ -296,38 +344,30 @@ INSTANCES." (guix-channel? (channel-instance-channel instance))) instances)) - (define dependencies - ;; Dependencies of CORE-INSTANCE. - ;; FIXME: It would be best not to hard-wire this information here and - ;; instead query it to CORE-INSTANCE. - (list (module-ref (resolve-interface '(gnu packages gnupg)) - 'guile-gcrypt) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-git) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-bytestructures))) - - (mlet %store-monad ((core (build-channel-instance core-instance))) - (mapm %store-monad - (lambda (instance) - (if (eq? instance core-instance) - (return core) - (match (channel-instance-dependencies instance) - (() - (build-channel-instance instance - (cons core dependencies))) - (channels - (mlet %store-monad ((dependencies-derivation - (latest-channel-derivation - ;; %default-channels is used here to - ;; ensure that the core channel is - ;; available for channels declared as - ;; dependencies. - (append channels %default-channels)))) - (build-channel-instance instance - (cons dependencies-derivation - (cons core dependencies)))))))) - instances))) + (define edges + (resolve-dependencies instances)) + + (define (instance->derivation instance) + (mcached (if (eq? instance core-instance) + (build-channel-instance instance) + (mlet %store-monad ((core (instance->derivation core-instance)) + (deps (mapm %store-monad instance->derivation + (edges instance)))) + (build-channel-instance instance core deps))) + instance)) + + (unless core-instance + (let ((loc (and=> (any (compose channel-location channel-instance-channel) + instances) + source-properties->location))) + (raise (apply make-compound-condition + (condition + (&message (message "'guix' channel is lacking"))) + (if loc + (list (condition (&error-location (location loc)))) + '()))))) + + (mapm %store-monad instance->derivation instances)) (define (whole-package-for-legacy name modules) "Return a full-blown Guix package for MODULES, a derivation that builds Guix @@ -335,6 +375,26 @@ modules in the old ~/.config/guix/latest style." (define packages (resolve-interface '(gnu packages guile))) + (define modules+compiled + ;; Since MODULES contains both .scm and .go files at its root, re-bundle + ;; it so that it has share/guile/site and lib/guile, which is what + ;; 'whole-package' expects. + (computed-file (derivation-name modules) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define version + (effective-version)) + (define share + (string-append #$output "/share/guile/site")) + (define lib + (string-append #$output "/lib/guile/" version)) + + (mkdir-p share) (mkdir-p lib) + (symlink #$modules (string-append share "/" version)) + (symlink #$modules (string-append lib "/site-ccache")))))) + (letrec-syntax ((list (syntax-rules (->) ((_) '()) @@ -346,7 +406,7 @@ modules in the old ~/.config/guix/latest style." ((_ variable rest ...) (cons (module-ref packages 'variable) (list rest ...)))))) - (whole-package name modules + (whole-package name modules+compiled ;; In the "old style", %SELF-BUILD-FILE would simply return a ;; derivation that builds modules. We have to infer what the @@ -396,11 +456,41 @@ channel instances." (zip instances derivations)))) (return (manifest entries)))) +(define (package-cache-file manifest) + "Build a package cache file for the instance in MANIFEST. This is meant to +be used as a profile hook." + (mlet %store-monad ((profile (profile-derivation manifest + #:hooks '()))) + + (define build + #~(begin + (use-modules (gnu packages)) + + (if (defined? 'generate-package-cache) + (begin + ;; Delegate package cache generation to the inferior. + (format (current-error-port) + "Generating package cache for '~a'...~%" + #$profile) + (generate-package-cache #$output)) + (mkdir #$output)))) + + (gexp->derivation-in-inferior "guix-package-cache" build + profile + #:properties '((type . profile-hook) + (hook . package-cache)) + #:local-build? #t))) + +(define %channel-profile-hooks + ;; The default channel profile hooks. + (cons package-cache-file %default-profile-hooks)) + (define (channel-instances->derivation instances) "Return the derivation of the profile containing INSTANCES, a list of channel instances." (mlet %store-monad ((manifest (channel-instances->manifest instances))) - (profile-derivation manifest))) + (profile-derivation manifest + #:hooks %channel-profile-hooks))) (define latest-channel-instances* (store-lift latest-channel-instances)) diff --git a/guix/config.scm.in b/guix/config.scm.in index 1a761b912e..d2ec9921c6 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; ;;; This file is part of GNU Guix. @@ -73,11 +73,11 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory diff --git a/guix/deprecation.scm b/guix/deprecation.scm new file mode 100644 index 0000000000..2f7c058940 --- /dev/null +++ b/guix/deprecation.scm @@ -0,0 +1,109 @@ +;;; 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 deprecation) + #:use-module (guix i18n) + #:use-module (ice-9 format) + #:export (define-deprecated + define-deprecated/alias + deprecation-warning-port)) + +;;; Commentary: +;;; +;;; Provide a mechanism to mark bindings as deprecated. +;;; +;;; We don't reuse (guix ui) mostly to avoid pulling in too many things. +;;; +;;; Code: + +(define deprecation-warning-port + ;; Port where deprecation warnings go. + (make-parameter (current-error-port))) + +(define (source-properties->location-string properties) + "Return a human-friendly, GNU-standard representation of PROPERTIES, a +source property alist." + (let ((file (assq-ref properties 'filename)) + (line (assq-ref properties 'line)) + (column (assq-ref properties 'column))) + (if (and file line column) + (format #f "~a:~a:~a" file (+ 1 line) column) + (G_ "<unknown location>")))) + +(define* (warn-about-deprecation variable properties + #:key replacement) + (format (deprecation-warning-port) + (G_ "~a: warning: '~a' is deprecated~@[, use '~a' instead~]~%") + (source-properties->location-string properties) + variable replacement)) + +(define-syntax define-deprecated + (lambda (s) + "Define a deprecated variable or procedure, along these lines: + + (define-deprecated foo bar 42) + (define-deprecated (baz x y) qux (qux y x)) + +This will write a deprecation warning to DEPRECATION-WARNING-PORT." + (syntax-case s () + ((_ (proc formals ...) replacement body ...) + #'(define-deprecated proc replacement + (lambda* (formals ...) body ...))) + ((_ variable replacement exp) + (identifier? #'variable) + (with-syntax ((real (datum->syntax + #'variable + (symbol-append '% + (syntax->datum #'variable) + '/deprecated)))) + #`(begin + (define real + (begin + (lambda () replacement) ;just to ensure it's bound + exp)) + + (define-syntax variable + (lambda (s) + (warn-about-deprecation 'variable (syntax-source s) + #:replacement 'replacement) + (syntax-case s () + ((_ args (... ...)) + #'(real args (... ...))) + (id + (identifier? #'id) + #'real)))))))))) + +(define-syntax-rule (define-deprecated/alias deprecated replacement) + "Define as an alias a deprecated variable, procedure, or macro, along +these lines: + + (define-deprecated/alias nix-server? store-connection?) + +where 'nix-server?' is the deprecated name for 'store-connection?'. + +This will write a deprecation warning to DEPRECATION-WARNING-PORT." + (define-syntax deprecated + (lambda (s) + (warn-about-deprecation 'deprecated (syntax-source s) + #:replacement 'replacement) + (syntax-case s () + ((_ args (... ...)) + #'(replacement args (... ...))) + (id + (identifier? #'id) + #'replacement))))) diff --git a/guix/derivations.scm b/guix/derivations.scm index f6176a78fd..fb2fa177be 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -113,7 +113,7 @@ ;;; Error conditions. ;;; -(define-condition-type &derivation-error &nix-error +(define-condition-type &derivation-error &store-error derivation-error? (derivation derivation-error-derivation)) diff --git a/guix/discovery.scm b/guix/discovery.scm index 3fc6e2c9e7..ef5ae73973 100644 --- a/guix/discovery.scm +++ b/guix/discovery.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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,7 +30,8 @@ scheme-modules* fold-modules all-modules - fold-module-public-variables)) + fold-module-public-variables + fold-module-public-variables*)) ;;; Commentary: ;;; @@ -147,10 +148,33 @@ search. Entries in PATH can be directory names (strings) or (DIRECTORY SUB-DIRECTORY." (fold-modules cons '() path #:warn warn)) +(define (fold-module-public-variables* proc init modules) + "Call (PROC MODULE SYMBOL VARIABLE) for each variable exported by one of MODULES, +using INIT as the initial value of RESULT. It is guaranteed to never traverse +the same object twice." + ;; Here SEEN is populated by variables; if two different variables refer to + ;; the same object, we still let them through. + (identity ;discard second return value + (fold2 (lambda (module result seen) + (fold2 (lambda (sym+var result seen) + (match sym+var + ((sym . var) + (if (not (vhash-assq var seen)) + (values (proc module sym var result) + (vhash-consq var #t seen)) + (values result seen))))) + result + seen + (module-map cons module))) + init + vlist-null + modules))) + (define (fold-module-public-variables proc init modules) "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES, using INIT as the initial value of RESULT. It is guaranteed to never traverse the same object twice." + ;; Note: here SEEN is populated by objects, not by variables. (identity ; discard second return value (fold2 (lambda (module result seen) (fold2 (lambda (var result seen) diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 0b8f61c276..8d5adcb8ed 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -154,7 +154,7 @@ TIMEOUT, an ETIMEDOUT error is raised." (catch 'system-error (lambda () (connect* s (addrinfo:addr ai) timeout) - (setvbuf s _IOLBF) + (setvbuf s 'line) (let-values (((code message) (%ftp-listen s))) (if (eqv? code 220) (begin @@ -237,7 +237,7 @@ TIMEOUT, an ETIMEDOUT error is raised." (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) (addrinfo:protocol ai)))) (connect* s (address-with-port (addrinfo:addr ai) port) timeout) - (setvbuf s _IOLBF) + (setvbuf s 'line) (dynamic-wind (lambda () #t) @@ -293,7 +293,7 @@ must be closed before CONN can be used for other purposes." (throw 'ftp-error conn "LIST" code message)))) (connect* s (address-with-port (addrinfo:addr ai) port) timeout) - (setvbuf s _IOLBF) + (setvbuf s 'line) (%ftp-command (string-append "RETR " file) 150 (ftp-connection-socket conn)) diff --git a/guix/gexp.scm b/guix/gexp.scm index 88cabc8ed5..f7c064297b 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; @@ -388,8 +388,9 @@ This is the declarative counterpart of 'gexp->derivation'." (mlet %store-monad ((guile (lower-object guile system #:target target))) (apply gexp->derivation name gexp #:guile-for-build guile - options)) - (apply gexp->derivation name gexp options))))) + #:system system #:target target options)) + (apply gexp->derivation name gexp + #:system system #:target target options))))) (define-record-type <program-file> (%program-file name gexp guile path) @@ -1314,30 +1315,33 @@ they can refer to each other." #:key (extensions '())) "Return as a monadic value a gexp that sets '%load-path' and '%load-compiled-path' to point to MODULES, a list of module names. MODULES -are searched for in PATH." - (mlet %store-monad ((modules (imported-modules modules - #:module-path path)) - (compiled (compiled-modules modules - #:extensions extensions - #:module-path path))) - (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)))))))) +are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." + (if (and (null? modules) (null? extensions)) + (with-monad %store-monad + (return #f)) + (mlet %store-monad ((modules (imported-modules modules + #:module-path path)) + (compiled (compiled-modules modules + #:extensions extensions + #:module-path path))) + (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))))))))) (define* (gexp->script name exp #:key (guile (default-guile)) @@ -1361,7 +1365,11 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH." "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) - (write '(ungexp set-load-path) port) + (ungexp-splicing + (if set-load-path + (gexp ((write '(ungexp set-load-path) port))) + (gexp ()))) + (write '(ungexp exp) port) (chmod port #o555)))) #:module-path module-path))) diff --git a/guix/grafts.scm b/guix/grafts.scm index db9c6854fd..a3e12f6efd 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -189,7 +189,7 @@ available." items))) (define (references* items) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; As a last resort, build DRV and query the references of the ;; build result. diff --git a/guix/http-client.scm b/guix/http-client.scm index 07360e6108..067002a79a 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -97,7 +97,7 @@ Raise an '&http-get-error' condition if downloading fails." headers)) (_ headers)))) (unless (or buffered? (not (file-port? port))) - (setvbuf port _IONBF)) + (setvbuf port 'none)) (let*-values (((resp data) (http-get uri #:streaming? #t #:port port #:keep-alive? #t diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 8f2c10258a..b287be6941 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; @@ -23,6 +23,7 @@ #:use-module (ice-9 regex) #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 receive) @@ -124,7 +125,7 @@ package definition." ((package-inputs ...) `((,type (,'quasiquote ,(format-inputs package-inputs))))))) -(define %cran-url "http://cran.r-project.org/web/packages/") +(define %cran-url "https://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") ;; The latest Bioconductor release is 3.8. Bioconductor packages should be @@ -160,6 +161,12 @@ bioconductor package NAME, or #F if the package is unknown." (bioconductor-packages-list)) (cut assoc-ref <> "Version"))) +;; Little helper to download URLs only once. +(define download + (memoize + (lambda (url) + (with-store store (download-to-store store url))))) + (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package NAME in the given REPOSITORY, or #f in case of failure. NAME is @@ -180,9 +187,9 @@ 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. - (let* ((version (latest-bioconductor-package-version name)) - (url (car (bioconductor-uri name version))) - (tarball (with-store store (download-to-store store url)))) + (and-let* ((version (latest-bioconductor-package-version name)) + (url (car (bioconductor-uri name version))) + (tarball (download url))) (call-with-temporary-directory (lambda (dir) (parameterize ((current-error-port (%make-void-port "rw+")) @@ -298,7 +305,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((url rest ...) url) ((? string? url) url) (_ #f))) - (tarball (with-store store (download-to-store store source-url))) + (tarball (download source-url)) (sysdepends (append (if (needs-zlib? tarball) '("zlib") '()) (map string-downcase (listify meta "SystemRequirements")))) @@ -346,10 +353,15 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (lambda* (package-name #:optional (repo 'cran)) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (and=> (fetch-description repo package-name) - (cut description->package repo <>))))) - -(define* (cran-recursive-import package-name #:optional (repo 'gnu)) + (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))))))) + +(define* (cran-recursive-import package-name #:optional (repo 'cran)) (recursive-import package-name repo #:repo->guix-package cran->guix-package #:guix-name cran-guix-name)) @@ -378,11 +390,11 @@ s-expression corresponding to that package, or #f on failure." (_ #f))) (_ #f))))) -(define (latest-cran-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define (latest-cran-release pkg) + "Return an <upstream-source> for the latest release of the package PKG." (define upstream-name - (package->upstream-name package)) + (package->upstream-name pkg)) (define meta (fetch-description 'cran upstream-name)) @@ -391,15 +403,18 @@ s-expression corresponding to that package, or #f on failure." (let ((version (assoc-ref meta "Version"))) ;; CRAN does not provide signatures. (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (cran-uri upstream-name version)))))) + (urls (cran-uri upstream-name version)) + (input-changes + (changed-inputs pkg + (description->package 'cran meta))))))) -(define (latest-bioconductor-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define (latest-bioconductor-release pkg) + "Return an <upstream-source> for the latest release of the package PKG." (define upstream-name - (package->upstream-name package)) + (package->upstream-name pkg)) (define version (latest-bioconductor-package-version upstream-name)) @@ -407,9 +422,13 @@ s-expression corresponding to that package, or #f on failure." (and version ;; Bioconductor does not provide signatures. (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (bioconductor-uri upstream-name version))))) + (urls (bioconductor-uri upstream-name version)) + (input-changes + (changed-inputs + pkg + (cran->guix-package upstream-name 'bioconductor)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." diff --git a/guix/import/github.scm b/guix/import/github.scm index af9f56e1dc..4d12339204 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -1,6 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org> +;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +26,7 @@ #:use-module (srfi srfi-34) #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) + #:use-module ((guix git-download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) #:use-module (guix packages) @@ -86,26 +89,31 @@ false if none is recognized" (#t #f))) ; Some URLs are not recognised. #f)) - (let ((source-url (and=> (package-source old-package) origin-uri)) + (let ((source-uri (and=> (package-source old-package) origin-uri)) (fetch-method (and=> (package-source old-package) origin-method))) - (if (eq? fetch-method download:url-fetch) - (match source-url - ((? string?) - (updated-url source-url)) - ((source-url ...) - (find updated-url source-url))) - #f))) + (cond + ((eq? fetch-method download:url-fetch) + (match source-uri + ((? string?) + (updated-url source-uri)) + ((source-uri ...) + (find updated-url source-uri)))) + ((and (eq? fetch-method download:git-fetch) + (string-prefix? "https://github.com/" + (download:git-reference-url source-uri))) + (download:git-reference-url source-uri)) + (else #f)))) (define (github-package? package) "Return true if PACKAGE is a package from GitHub, else false." - (not (eq? #f (updated-github-url package "dummy")))) + (->bool (updated-github-url package "dummy"))) (define (github-repository url) "Return a string e.g. bedtools2 of the name of the repository, from a string URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'" (match (string-split (uri-path (string->uri url)) #\/) ((_ owner project . rest) - (string-append project)))) + (string-append (basename project ".git"))))) (define (github-user-slash-repository url) "Return a string e.g. arq5x/bedtools2 of the owner and the name of the @@ -113,7 +121,7 @@ repository separated by a forward slash, from a string URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'" (match (string-split (uri-path (string->uri url)) #\/) ((_ owner project . rest) - (string-append owner "/" project)))) + (string-append owner "/" (basename project ".git"))))) (define %github-token ;; Token to be passed to Github.com to avoid the 60-request per hour @@ -163,6 +171,9 @@ empty list." "Return a string of the newest released version name given a string URL like 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of the package e.g. 'bedtools2'. Return #f if there is no releases" + (define (pre-release? x) + (hash-ref x "prerelease")) + (let* ((json (fetch-releases-or-tags url))) (if (eq? json #f) (if (%github-token) @@ -172,40 +183,32 @@ API when using a GitHub token") API. This may be fixed by using an access token and setting the environment variable GUIX_GITHUB_TOKEN, for instance one procured from https://github.com/settings/tokens")) - (let loop ((releases - (filter - (lambda (x) - ;; example pre-release: - ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1 - ;; or an all-prerelease set - ;; https://github.com/powertab/powertabeditor/releases - (not (hash-ref x "prerelease"))) - json))) - (match releases - (() ;empty release list - #f) - ((release . rest) ;one or more releases - (let ((tag (or (hash-ref release "tag_name") ;a "release" - (hash-ref release "name"))) ;a tag - (name-length (string-length package-name))) - ;; some tags include the name of the package e.g. "fdupes-1.51" - ;; so remove these - (if (and (< name-length (string-length tag)) - (string=? (string-append package-name "-") - (substring tag 0 (+ name-length 1)))) - (substring tag (+ name-length 1)) - ;; some tags start with a "v" e.g. "v0.25.0" - ;; where some are just the version number - (if (string-prefix? "v" tag) - (substring tag 1) - - ;; Finally, reject tags that don't start with a digit: - ;; they may not represent a release. - (if (and (not (string-null? tag)) - (char-set-contains? char-set:digit - (string-ref tag 0))) - tag - (loop rest))))))))))) + (any + (lambda (release) + (let ((tag (or (hash-ref release "tag_name") ;a "release" + (hash-ref release "name"))) ;a tag + (name-length (string-length package-name))) + (cond + ;; some tags include the name of the package e.g. "fdupes-1.51" + ;; so remove these + ((and (< name-length (string-length tag)) + (string=? (string-append package-name "-") + (substring tag 0 (+ name-length 1)))) + (substring tag (+ name-length 1))) + ;; some tags start with a "v" e.g. "v0.25.0" + ;; where some are just the version number + ((string-prefix? "v" tag) + (substring tag 1)) + ;; Finally, reject tags that don't start with a digit: + ;; they may not represent a release. + ((and (not (string-null? tag)) + (char-set-contains? char-set:digit + (string-ref tag 0))) + tag) + (else #f)))) + (match (remove pre-release? json) + (() json) ; keep everything + (releases releases)))))) (define (latest-release pkg) "Return an <upstream-source> for the latest release of PKG." @@ -213,6 +216,8 @@ https://github.com/settings/tokens")) (match (origin-uri origin) ((? string? url) url) ;surely a github.com URL + ((? download:git-reference? ref) + (download:git-reference-url ref)) ((urls ...) (find (cut string-contains <> "github.com") urls)))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index c42a5d767d..c254db5f2c 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -27,16 +27,23 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (web uri) + #:use-module (guix build-system) + #:use-module (guix build-system ocaml) #:use-module (guix http-client) #:use-module (guix git) #:use-module (guix ui) + #:use-module (guix packages) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) - #:export (opam->guix-package)) + #:export (opam->guix-package + opam-recursive-import + %opam-updater)) ;; Define a PEG parser for the opam format -(define-peg-pattern SP none (or " " "\n")) +(define-peg-pattern comment none (and "#" (* STRCHR) "\n")) +(define-peg-pattern SP none (or " " "\n" comment)) (define-peg-pattern SP2 body (or " " "\n")) (define-peg-pattern QUOTE none "\"") (define-peg-pattern QUOTE2 body "\"") @@ -128,7 +135,6 @@ path to the repository." (else (string-append "ocaml-" name)))) (define (metadata-ref file lookup) - (pk 'file file 'lookup lookup) (fold (lambda (record acc) (match record ((record key val) @@ -166,6 +172,21 @@ path to the repository." (('conditional-value val condition) (if (native? condition) (dependency->input val) "")))) +(define (dependency->name dependency) + (match dependency + (('string-pat str) str) + (('conditional-value val condition) + (dependency->name val)))) + +(define (dependency-list->names lst) + (filter + (lambda (name) + (not (or + (string-prefix? "conf-" name) + (equal? name "ocaml") + (equal? name "findlib")))) + (map dependency->name lst))) + (define (ocaml-names->guix-names names) (map ocaml-name->guix-name (remove (lambda (name) @@ -190,35 +211,88 @@ path to the repository." (list dependency (list 'unquote (string->symbol dependency)))) (ocaml-names->guix-names lst))) -(define (opam->guix-package name) +(define (opam-fetch name) (and-let* ((repository (get-opam-repository)) (version (find-latest-version name repository)) - (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam")) - (opam-content (get-metadata file)) - (url-dict (metadata-ref (pk 'metadata opam-content) "url")) + (file (string-append repository "/packages/" name "/" name "." version "/opam"))) + `(("metadata" ,@(get-metadata file)) + ("version" . ,version)))) + +(define (opam->guix-package name) + (and-let* ((opam-file (opam-fetch name)) + (version (assoc-ref opam-file "version")) + (opam-content (assoc-ref opam-file "metadata")) + (url-dict (metadata-ref opam-content "url")) (source-url (metadata-ref url-dict "src")) (requirements (metadata-ref opam-content "depends")) + (dependencies (dependency-list->names requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) (native-inputs (dependency-list->inputs (depends->native-inputs requirements)))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) - `(package - (name ,(ocaml-name->guix-name name)) - (version ,(metadata-ref opam-content "version")) - (source - (origin - (method url-fetch) - (uri ,source-url) - (sha256 (base32 ,(guix-hash-url temp))))) - (build-system ocaml-build-system) - ,@(if (null? inputs) - '() - `((inputs ,(list 'quasiquote inputs)))) - ,@(if (null? native-inputs) - '() - `((native-inputs ,(list 'quasiquote native-inputs)))) - (home-page ,(metadata-ref opam-content "homepage")) - (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) - (license #f))))))) + (values + `(package + (name ,(ocaml-name->guix-name name)) + (version ,version) + (source + (origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ocaml-build-system) + ,@(if (null? inputs) + '() + `((inputs ,(list 'quasiquote inputs)))) + ,@(if (null? native-inputs) + '() + `((native-inputs ,(list 'quasiquote native-inputs)))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(metadata-ref opam-content "description")) + (license #f)) + dependencies)))))) + +(define (opam-recursive-import package-name) + (recursive-import package-name #f + #:repo->guix-package (lambda (name repo) + (opam->guix-package name)) + #:guix-name ocaml-name->guix-name)) + +(define (guix-package->opam-name package) + "Given an OCaml PACKAGE built from OPAM, return the name of the +package in OPAM." + (let ((upstream-name (assoc-ref + (package-properties package) + 'upstream-name)) + (name (package-name package))) + (cond + (upstream-name upstream-name) + ((string-prefix? "ocaml-" name) (substring name 6)) + (else name)))) + +(define (opam-package? package) + "Return true if PACKAGE is an OCaml package from OPAM" + (and + (equal? (build-system-name (package-build-system package)) 'ocaml) + (not (string-prefix? "ocaml4" (package-name package))))) + +(define (latest-release package) + "Return an <upstream-source> for the latest release of PACKAGE." + (and-let* ((opam-name (guix-package->opam-name package)) + (opam-file (opam-fetch opam-name)) + (version (assoc-ref opam-file "version")) + (opam-content (assoc-ref opam-file "metadata")) + (url-dict (metadata-ref opam-content "url")) + (source-url (metadata-ref url-dict "src"))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list source-url))))) + +(define %opam-updater + (upstream-updater + (name 'opam) + (description "Updater for OPAM packages") + (pred opam-package?) + (latest latest-release))) diff --git a/guix/inferior.scm b/guix/inferior.scm index ccc1c27cb2..6cfa146029 100644 --- a/guix/inferior.scm +++ b/guix/inferior.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. ;;; @@ -26,9 +26,9 @@ version>? version-prefix? cache-directory)) #:use-module ((guix store) - #:select (nix-server-socket - nix-server-major-version - nix-server-minor-version + #:select (store-connection-socket + store-connection-major-version + store-connection-minor-version store-lift)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) @@ -54,6 +54,7 @@ #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior + port->inferior close-inferior inferior-eval inferior-eval-with-store @@ -80,6 +81,8 @@ inferior-package->manifest-entry + gexp->derivation-in-inferior + %inferior-cache-directory inferior-for-channels)) @@ -93,10 +96,11 @@ ;; Inferior Guix process. (define-record-type <inferior> - (inferior pid socket version packages table) + (inferior pid socket close version packages table) inferior? (pid inferior-pid) (socket inferior-socket) + (close inferior-close-socket) ;procedure (version inferior-version) ;REPL protocol version (packages inferior-package-promise) ;promise of inferior packages (table inferior-package-table)) ;promise of vhash @@ -131,19 +135,15 @@ it's an old Guix." ((@ (guix scripts repl) machine-repl)))))) pipe))) -(define* (open-inferior directory #:key (command "bin/guix")) - "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or -equivalent. Return #f if the inferior could not be launched." - (define pipe - (inferior-pipe directory command)) - - (cond-expand - ((and guile-2 (not guile-2.2)) #t) - (else (setvbuf pipe 'line))) +(define* (port->inferior pipe #:optional (close close-port)) + "Given PIPE, an input/output port, return an inferior that talks over PIPE. +PIPE is closed with CLOSE when 'close-inferior' is called on the returned +inferior." + (setvbuf pipe 'line) (match (read pipe) (('repl-version 0 rest ...) - (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) @@ -155,9 +155,18 @@ equivalent. Return #f if the inferior could not be launched." (_ #f))) +(define* (open-inferior directory #:key (command "bin/guix")) + "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or +equivalent. Return #f if the inferior could not be launched." + (define pipe + (inferior-pipe directory command)) + + (port->inferior pipe close-pipe)) + (define (close-inferior inferior) "Close INFERIOR." - (close-pipe (inferior-socket inferior))) + (let ((close (inferior-close-socket inferior))) + (close (inferior-socket inferior)))) ;; Non-self-quoting object of the inferior. (define-record-type <inferior-object> @@ -382,8 +391,8 @@ input/output ports.)" ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. - (setvbuf client _IOFBF 65536) - (setvbuf backend _IOFBF 65536) + (setvbuf client 'block 65536) + (setvbuf backend 'block 65536) (let loop () (match (select* (list client backend) '() '()) @@ -409,13 +418,14 @@ thus be the code of a one-argument procedure that accepts a store." ;; Create a named socket in /tmp and let INFERIOR connect to it and use it ;; as its store. This ensures the inferior uses the same store, with the ;; same options, the same per-session GC roots, etc. + ;; FIXME: This strategy doesn't work for remote inferiors (SSH). (call-with-temporary-directory (lambda (directory) (chmod directory #o700) (let* ((name (string-append directory "/inferior")) (socket (socket AF_UNIX SOCK_STREAM 0)) - (major (nix-server-major-version store)) - (minor (nix-server-minor-version store)) + (major (store-connection-major-version store)) + (minor (store-connection-minor-version store)) (proto (logior major minor))) (bind socket AF_UNIX name) (listen socket 1024) @@ -441,7 +451,7 @@ thus be the code of a one-argument procedure that accepts a store." inferior) (match (accept socket) ((client . address) - (proxy client (nix-server-socket store)))) + (proxy client (store-connection-socket store)))) (close-port socket) (read-inferior-response inferior))))) @@ -476,6 +486,37 @@ PACKAGE must be live." ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. (inferior-package->derivation package system #:target target)) +(define* (gexp->derivation-in-inferior name exp guix + #:rest rest) + "Return a derivation that evaluates EXP with GUIX, an instance of Guix as +returned for example by 'channel-instances->derivation'. Other arguments are +passed as-is to 'gexp->derivation'." + (define script + ;; EXP wrapped with a proper (set! %load-path …) prologue. + (scheme-file "inferior-script.scm" exp)) + + (define trampoline + ;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and + ;; make 'guix repl' the "builder"; this will require "opening up" the + ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'. + #~(begin + (use-modules (ice-9 popen)) + + (let ((pipe (open-pipe* OPEN_WRITE + #+(file-append guix "/bin/guix") + "repl" "-t" "machine"))) + + ;; XXX: EXP presumably refers to #$output but that reference is lost + ;; so explicitly reference it here. + #$output + + (write `(primitive-load #$script) pipe) + + (unless (zero? (close-pipe pipe)) + (error "inferior failed" #+guix))))) + + (apply gexp->derivation name trampoline rest)) + ;;; ;;; Manifest entries. diff --git a/guix/licenses.scm b/guix/licenses.scm index 4ef18fb326..4ef3ed188c 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> -;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Leo Famulari <leo@famulari.name> ;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de> @@ -65,7 +65,7 @@ ipa knuth lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ - lppl lppl1.0+ lppl1.2 lppl1.2+ + lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+ lppl1.3 lppl1.3+ lppl1.3a lppl1.3a+ lppl1.3b lppl1.3b+ @@ -421,6 +421,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.latex-project.org/lppl/lppl-1-0/" "LaTeX Project Public License 1.0")) +(define lppl1.1+ + (license "LPPL 1.1+" + "https://www.latex-project.org/lppl/lppl-1-1/" + "LaTeX Project Public License 1.1")) + (define lppl1.2 (license "LPPL 1.2" "http://directory.fsf.org/wiki/License:LPPLv1.2" diff --git a/guix/packages.scm b/guix/packages.scm index e4c2ac3be5..8515bb7c6f 100644 --- a/guix/packages.scm +++ b/guix/packages.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 © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> @@ -133,6 +133,7 @@ bag-transitive-host-inputs bag-transitive-build-inputs bag-transitive-target-inputs + package-closure default-guile default-guile-derivation @@ -798,6 +799,28 @@ dependencies are known to build on SYSTEM." "Return the \"target inputs\" of BAG, recursively." (transitive-inputs (bag-target-inputs bag))) +(define* (package-closure packages #:key (system (%current-system))) + "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of +packages they depend on, recursively." + (let loop ((packages packages) + (visited vlist-null) + (closure (list->setq packages))) + (match packages + (() + (set->list closure)) + ((package . rest) + (if (vhash-assq package visited) + (loop rest visited closure) + (let* ((bag (package->bag package system)) + (dependencies (filter-map (match-lambda + ((label (? package? package) . _) + package) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append dependencies rest) + (vhash-consq package #t visited) + (fold set-insert closure dependencies)))))))) + (define* (package-mapping proc #:optional (cut? (const #f))) "Return a procedure that, given a package, applies PROC to all the packages depended on and returns the resulting package. The procedure stops recursion @@ -832,19 +855,27 @@ when CUT? returns true for a given package." #:optional (rewrite-name identity)) "Return a procedure that, when passed a package, replaces its direct and indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. -REPLACEMENTS is a list of package pairs; the first element of each pair is the -package to replace, and the second one is the replacement. +REPLACEMENTS is a list of package pairs or a promise thereof; the first +element of each pair is the package to replace, and the second one is the +replacement. Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a package and returns its new name after rewrite." (define (rewrite p) - (match (assq-ref replacements p) + (match (assq-ref (if (promise? replacements) + (force replacements) + replacements) + p) (#f (package (inherit p) (name (rewrite-name (package-name p))))) (new new))) - (package-mapping rewrite (cut assq <> replacements))) + (package-mapping rewrite + (lambda (package) + (assq package (if (promise? replacements) + (force replacements) + replacements))))) (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same diff --git a/guix/profiles.scm b/guix/profiles.scm index 8142e5e8e2..efe5ecb9dc 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,10 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> -;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> ;;; Copyright © 2017 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -1300,12 +1300,22 @@ the entries in MANIFEST." (srfi srfi-19)) (define (compute-entries) - (append-map (lambda (directory) - (let ((man (string-append directory "/share/man"))) - (if (directory-exists? man) - (mandb-entries man) - '()))) - '#$(manifest-inputs manifest))) + ;; This is the most expensive part (I/O and CPU, due to + ;; decompression), so report progress as we traverse INPUTS. + (let* ((inputs '#$(manifest-inputs manifest)) + (total (length inputs))) + (append-map (lambda (directory count) + (format #t "\r[~3d/~3d] building list of \ +man-db entries..." + count total) + (force-output) + (let ((man (string-append directory + "/share/man"))) + (if (directory-exists? man) + (mandb-entries man) + '()))) + inputs + (iota total 1)))) (define man-directory (string-append #$output "/share/man")) @@ -1320,6 +1330,7 @@ the entries in MANIFEST." "/index.db") entries)) (duration (time-difference (current-time) start))) + (newline) (format #t "~a entries processed in ~,1f s~%" (length entries) (+ (time-second duration) @@ -1338,6 +1349,53 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) +(define (texlive-configuration manifest) + "Return a derivation that builds a TeXlive configuration for the entries in +MANIFEST." + (define entry->texlive-input + (match-lambda + (($ <manifest-entry> name version output thing deps) + (if (string-prefix? "texlive-" name) + (cons (gexp-input thing output) + (append-map entry->texlive-input deps)) + '())))) + (define build + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (guix build utils) + (guix build union)) + + ;; Build a modifiable union of all texlive inputs. We do this so + ;; that TeX live can resolve the parent and grandparent directories + ;; correctly. There might be a more elegant way to accomplish this. + (union-build #$output + '#$(append-map entry->texlive-input + (manifest-entries manifest)) + #:create-all-directories? #t + #:log-port (%make-void-port "w")) + (let ((texmf.cnf (string-append + #$output + "/share/texmf-dist/web2c/texmf.cnf"))) + (when (file-exists? texmf.cnf) + (substitute* texmf.cnf + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " #$output "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")))) + #t))) + + (with-monad %store-monad + (if (any (cut string-prefix? "texlive-" <>) + (map manifest-entry-name (manifest-entries manifest))) + (gexp->derivation "texlive-configuration" build + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . texlive-configuration))) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. @@ -1349,6 +1407,7 @@ the entries in MANIFEST." glib-schemas gtk-icon-themes gtk-im-modules + texlive-configuration xdg-desktop-database xdg-mime-database)) diff --git a/guix/profiling.scm b/guix/profiling.scm index 753fc6c22e..e1c205a543 100644 --- a/guix/profiling.scm +++ b/guix/profiling.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. ;;; @@ -18,6 +18,7 @@ (define-module (guix profiling) #:use-module (ice-9 match) + #:autoload (ice-9 format) (format) #:export (profiled? register-profiling-hook!)) @@ -50,3 +51,25 @@ (for-each (lambda (hook) (add-hook! hook thunk)) %profiling-hooks))) + +(define (show-gc-stats) + "Display garbage collection statistics." + (define MiB (* 1024 1024.)) + (define stats (gc-stats)) + + (format (current-error-port) "Garbage collection statistics: + heap size: ~,2f MiB + allocated: ~,2f MiB + GC times: ~a + time spent in GC: ~,2f seconds (~d% of user time)~%" + (/ (assq-ref stats 'heap-size) MiB) + (/ (assq-ref stats 'heap-total-allocated) MiB) + (assq-ref stats 'gc-times) + (/ (assq-ref stats 'gc-time-taken) + internal-time-units-per-second 1.) + (inexact->exact + (round (* (/ (assq-ref stats 'gc-time-taken) + (tms:utime (times)) 1.) + 100))))) + +(register-profiling-hook! "gc" show-gc-stats) diff --git a/guix/records.scm b/guix/records.scm index 98f3c8fef0..0649c90ea3 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,6 @@ ;;; 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. ;;; @@ -43,15 +44,6 @@ (format #f fmt args ...) form)))) -(define (report-invalid-field-specifier name bindings) - "Report the first invalid binding among BINDINGS." - (let loop ((bindings bindings)) - (syntax-case bindings () - (((field value) rest ...) ;good - (loop #'(rest ...))) - ((weird _ ...) ;weird! - (syntax-violation name "invalid field specifier" #'weird))))) - (eval-when (expand load eval) ;; The procedures below are needed both at run time and at expansion time. @@ -74,7 +66,32 @@ interface\" (ABI) for TYPE is equal to COOKIE." ;; recompiled. (throw 'record-abi-mismatch-error 'abi-check "~a: record ABI mismatch; recompilation needed" - (list #,type) '()))))) + (list #,type) '())))) + + (define (report-invalid-field-specifier name bindings) + "Report the first invalid binding among BINDINGS." + (let loop ((bindings bindings)) + (syntax-case bindings () + (((field value) rest ...) ;good + (loop #'(rest ...))) + ((weird _ ...) ;weird! + (syntax-violation name "invalid field specifier" #'weird))))) + + (define (report-duplicate-field-specifier name ctor) + "Report the first duplicate identifier among the bindings in CTOR." + (syntax-case ctor () + ((_ bindings ...) + (let loop ((bindings #'(bindings ...)) + (seen '())) + (syntax-case bindings () + (((field value) rest ...) + (not (memq (syntax->datum #'field) seen)) + (loop #'(rest ...) (cons (syntax->datum #'field) seen))) + ((duplicate rest ...) + (syntax-violation name "duplicate field initializer" + #'duplicate)) + (() + #t))))))) (define-syntax make-syntactic-constructor (syntax-rules () @@ -169,6 +186,9 @@ of TYPE matches the expansion-time ABI." #'(field (... ...))) (wrap-field-value f (field-default-value f)))) + ;; Pass S to make sure source location info is preserved. + (report-duplicate-field-specifier 'name s) + (let ((fields (append fields (map car default-values)))) (cond ((lset= eq? fields '(expected ...)) #`(let* #,(field-bindings diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index fb2f61ce30..950f0f41d8 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) @@ -55,7 +56,11 @@ (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix archive [OPTION]... PACKAGE... @@ -85,6 +90,8 @@ Export/import one or more packages from/to the store.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) @@ -161,6 +168,11 @@ Export/import one or more packages from/to the store.\n")) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -239,7 +251,6 @@ build and a list of store files to transfer." resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) - (set-build-options-from-command-line store opts) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) @@ -329,21 +340,23 @@ the input port." ((assoc-ref opts 'authorize) (authorize-key)) (else - (with-store store - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%")))))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (G_ "either '--export' or '--import' \ +must be specified~%"))))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 0b7da3189e..5a158799ae 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.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 © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -450,13 +450,13 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " --timeout=SECONDS mark the build as failed after SECONDS of activity")) (display (G_ " - --verbosity=LEVEL use the given verbosity LEVEL")) - (display (G_ " --rounds=N build N times in a row to detect non-determinism")) (display (G_ " -c, --cores=N allow the use of up to N CPU cores for the build")) (display (G_ " - -M, --max-jobs=N allow at most N build jobs"))) + -M, --max-jobs=N allow at most N build jobs")) + (display (G_ " + --debug=LEVEL produce debugging output at LEVEL"))) (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given @@ -479,7 +479,7 @@ options handled by 'set-build-options-from-command-line', and listed in (assoc-ref opts 'print-extended-build-trace?) #:multiplexed-build-output? (assoc-ref opts 'multiplexed-build-output?) - #:verbosity (assoc-ref opts 'verbosity))) + #:verbosity (assoc-ref opts 'debug))) (define set-build-options-from-command-line* (store-lift set-build-options-from-command-line)) @@ -553,12 +553,12 @@ options handled by 'set-build-options-from-command-line', and listed in (apply values (alist-cons 'timeout (string->number* arg) result) rest))) - (option '("verbosity") #t #f + (option '("debug") #t #f (lambda (opt name arg result . rest) - (let ((level (string->number arg))) + (let ((level (string->number* arg))) (apply values - (alist-cons 'verbosity level - (alist-delete 'verbosity result)) + (alist-cons 'debug level + (alist-delete 'debug result)) rest)))) (option '(#\c "cores") #t #f (lambda (opt name arg result . rest) @@ -590,7 +590,8 @@ options handled by 'set-build-options-from-command-line', and listed in (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... @@ -619,6 +620,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " -q, --quiet do not show the build log")) (display (G_ " --log-file return the log file names for the given derivations")) @@ -694,9 +697,15 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\q "quiet") #f #f (lambda (opt name arg result) - (alist-cons 'quiet? #t result))) + (alist-cons 'verbosity 0 + (alist-delete 'verbosity result)))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) @@ -788,13 +797,15 @@ package '~a' has no source~%") ((? file-like? obj) (list (run-with-store store (lower-object obj system - #:target (assoc-ref opts 'target))))) + #:target (assoc-ref opts 'target)) + #:system system))) ((? gexp? gexp) (list (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) (gexp->derivation "gexp" gexp - #:system system)))))) + #:system system)) + #:system system)))) (map (cut transform store <>) (options->things-to-build opts)))))) @@ -817,66 +828,59 @@ needed." (parse-command-line args %options (list %default-options))) - (define quiet? - (assoc-ref opts 'quiet?)) - (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (with-store store - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - - (parameterize ((current-terminal-columns (terminal-columns)) - (current-build-output-port - (if quiet? - (%make-void-port "w") - (build-event-output-port - (build-status-updater print-build-event))))) - (let* ((mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - - (unless (or (assoc-ref opts 'log-file?) - (assoc-ref opts 'derivations-only?)) - (show-what-to-build store drv - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((current-terminal-columns (terminal-columns))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (or (assoc-ref opts 'log-file?) + (assoc-ref opts 'derivations-only?)) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots))))))))))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f0693ed8df..65de42053d 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -109,7 +109,7 @@ "Return the hash of ITEM, a store item, if ITEM was built locally. Otherwise return #f." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (values #f store))) (if (locally-built? store item) (values (query-path-hash store item) store) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 4c85929858..be4ce4364b 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (guix scripts) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix scripts build) @@ -116,6 +117,8 @@ Copy ITEMS to or from the specified host over SSH.\n")) --to=HOST send ITEMS to HOST")) (display (G_ " --from=HOST receive ITEMS from HOST")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) (newline) @@ -134,6 +137,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (option '("from") #t #f (lambda (opt name arg result) (alist-cons 'source arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -152,7 +160,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (debug . 0) + (verbosity . 2))) ;;; @@ -164,6 +176,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (let* ((opts (parse-command-line args %options (list %default-options))) (source (assoc-ref opts 'source)) (target (assoc-ref opts 'destination))) - (cond (target (send-to-remote-host target opts)) - (source (retrieve-from-remote-host source opts)) - (else (leave (G_ "use '--to' or '--from'~%"))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (G_ "use '--to' or '--from'~%")))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index b9162d3449..d8fe71ce12 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -77,7 +77,7 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) - (format #f (G_ " + (format #t (G_ " -o, --output=FILE download to FILE")) (newline) (display (G_ " diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8b2b61d76a..da3d2775e8 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix utils) - #:use-module (guix packages) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -63,14 +62,13 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) file path)) absolute-file-name)) -(define (package->location-specification package) - "Return the location specification for PACKAGE for a typical editor command +(define (location->location-specification location) + "Return the location specification for LOCATION for a typical editor command line." - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) + (list (string-append "+" + (number->string + (location-line location))) + (search-path* %load-path (location-file location)))) (define (guix-edit . args) @@ -83,18 +81,13 @@ line." '())) (with-error-handling - (let* ((specs (reverse (parse-arguments))) - (packages (map specification->package specs))) - (for-each (lambda (package) - (unless (package-location package) - (leave (G_ "source location of package '~a' is unknown~%") - (package-full-name package)))) - packages) + (let* ((specs (reverse (parse-arguments))) + (locations (map specification->location specs))) (catch 'system-error (lambda () - (let ((file-names (append-map package->location-specification - packages))) + (let ((file-names (append-map location->location-specification + locations))) ;; Use `system' instead of `exec' in order to sanely handle ;; possible command line arguments in %EDITOR. (exit (system (string-join (cons (%editor) file-names)))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 86e1eb115f..116b8dcbce 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -158,6 +158,8 @@ COMMAND or an interactive shell in that environment.\n")) --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) @@ -179,7 +181,8 @@ COMMAND or an interactive shell in that environment.\n")) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 2))) (define (tag-package-arg opts arg) "Return a two-element list with the form (TAG ARG) that tags ARG with either @@ -260,6 +263,11 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -674,7 +682,7 @@ message if any test fails." (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) (define manifest (options/resolve-packages store opts)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 145a574dba..8efeef3274 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -299,7 +299,7 @@ this type of graph"))))))) information available in the local store or using information about substitutes." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (match (substitutable-path-info store (list item)) ((info) (values (substitutable-references info) store)) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index b549878742..2d249a213f 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -25,6 +25,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-opam)) @@ -43,6 +44,8 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -56,6 +59,9 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import opam"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -81,11 +87,22 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (opam->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (opam-recursive-import package-name)))) + ;; Single import + (let ((sexp (opam->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2314f3b28c..ddad5b7fd0 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,13 +1,14 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,8 +45,10 @@ #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:use-module (web client) #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors @@ -73,7 +76,9 @@ check-home-page check-source check-source-file-name + check-source-unstable-tarball check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -590,7 +595,8 @@ from ~a") 'home-page))))) (define %distro-directory - (dirname (search-path %load-path "gnu.scm"))) + (mlambda () + (dirname (search-path %load-path "gnu.scm")))) (define (check-patch-file-names package) "Emit a warning if the patches requires by PACKAGE are badly named or if the @@ -615,12 +621,12 @@ patch could not be found." 'patch-file-names)) ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length %distro-directory)) + (let ((prefix (string-length (%distro-directory))) (margin (string-length "guix-0.13.0-10-123456789/")) (max 99)) (for-each (match-lambda ((? string? patch) - (when (> (+ margin (if (string-prefix? %distro-directory + (when (> (+ margin (if (string-prefix? (%distro-directory) patch) (- (string-length patch) prefix) (string-length patch))) @@ -748,6 +754,23 @@ descriptions maintained upstream." (G_ "the source file name should contain the package name") 'source)))) +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (when (and (string=? (uri-host (string->uri uri)) "github.com") + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) + (emit-warning package + (G_ "the source URI should not be an autogenerated tarball") + 'source))) + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (for-each check-source-uri uris))))) + (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." (define (check-mirror-uri uri) ;XXX: could be optimized @@ -773,16 +796,48 @@ descriptions maintained upstream." (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) +(define (check-github-url package) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect uri) + (receive (response body) (http-head uri) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (for-each + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (unless (string=? github-uri uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source))))) + (origin-uris origin))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try system) (catch #t (lambda () - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") system - (nix-protocol-error-message c)))) + (store-protocol-error-message c)))) ((message-condition? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") @@ -1056,10 +1111,18 @@ or a list thereof") (description "Suggest 'mirror://' URLs") (check check-mirror-url)) (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) + (lint-checker (name 'source-file-name) (description "Validate file names of sources") (check check-source-file-name)) (lint-checker + (name 'source-unstable-tarball) + (description "Check for autogenerated tarballs") + (check check-source-unstable-tarball)) + (lint-checker (name 'derivation) (description "Report failure to compile a package to a derivation") (check check-derivation)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index ee5857e16b..eb02672dbf 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -23,13 +23,12 @@ #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh popen) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix derivations) #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) @@ -261,13 +260,6 @@ instead of '~a' of type '~a'~%") (lambda () (unlock-file port))))) -(define-syntax-rule (with-machine-lock machine hint exp ...) - "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that -context." - (with-file-lock (machine-lock-file machine hint) - exp ...)) - - (define (machine-slot-file machine slot) "Return the file name of MACHINE's file for SLOT." ;; For each machine we have a bunch of files representing each build slot. @@ -285,23 +277,25 @@ the slot, or #f if none is available. This mechanism allows us to set a hard limit on the number of simultaneous connections allowed to MACHINE." (mkdir-p (dirname (machine-slot-file machine 0))) - (with-machine-lock machine 'slots - (any (lambda (slot) - (let ((port (open-file (machine-slot-file machine slot) - "w0"))) - (catch 'flock-error - (lambda () - (fcntl-flock port 'write-lock #:wait? #f) - ;; Got it! - (format (current-error-port) - "process ~a acquired build slot '~a'~%" - (getpid) (port-filename port)) - port) - (lambda args - ;; PORT is already locked by another process. - (close-port port) - #f)))) - (iota (build-machine-parallel-builds machine))))) + + ;; When several 'guix offload' processes run in parallel, there's a race + ;; among them, but since they try the slots in the same order, we're fine. + (any (lambda (slot) + (let ((port (open-file (machine-slot-file machine slot) + "w0"))) + (catch 'flock-error + (lambda () + (fcntl-flock port 'write-lock #:wait? #f) + ;; Got it! + (format (current-error-port) + "process ~a acquired build slot '~a'~%" + (getpid) (port-filename port)) + port) + (lambda args + ;; PORT is already locked by another process. + (close-port port) + #f)))) + (iota (build-machine-parallel-builds machine)))) (define (release-build-slot slot) "Release SLOT, a build slot as returned as by 'acquire-build-slot'." @@ -321,6 +315,16 @@ hook." (set-port-revealed! port 1) port)) +(define (node-guile-version node) + (inferior-eval '(version) node)) + +(define (node-free-disk-space node) + "Return the free disk space, in bytes, in NODE's store." + (inferior-eval `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))) + node)) + (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -354,15 +358,29 @@ MACHINE." (format (current-error-port) "@ build-remote ~a ~a~%" (derivation-file-name drv) (build-machine-name machine)) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (format (current-error-port) (G_ "derivation '~a' offloaded to '~a' failed: ~a~%") (derivation-file-name drv) (build-machine-name machine) - (nix-protocol-error-message c)) - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100))) + (store-protocol-error-message c)) + (let* ((inferior (false-if-exception (remote-inferior session))) + (space (false-if-exception + (node-free-disk-space inferior)))) + + (when inferior + (close-inferior inferior)) + + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (if (and space (< space (* 10 (expt 2 20)))) + (begin + (format (current-error-port) + (G_ "build failure may have been caused by lack \ +of free disk space on '~a'~%") + (build-machine-name machine)) + (primitive-exit 1)) + (primitive-exit 100))))) (parameterize ((current-build-output-port (build-log-port))) (build-derivations store (list drv)))) @@ -392,43 +410,37 @@ MACHINE." (build-requirements-features requirements) (build-machine-features machine)))) -(define (machine-load machine) - "Return the load of MACHINE, divided by the number of parallel builds -allowed on MACHINE. Return +∞ if MACHINE is unreachable." - ;; Note: This procedure is costly since it creates a new SSH session. - (match (false-if-exception (open-ssh-session machine)) - ((? session? session) - (let* ((pipe (open-remote-pipe* session OPEN_READ - "cat" "/proc/loadavg")) - (line (read-line pipe))) - (close-port pipe) - (disconnect! session) - - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded - (match (string-tokenize line) - ((one five fifteen . x) - (let* ((raw (string->number one)) - (jobs (build-machine-parallel-builds machine)) - (normalized (/ raw jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ +(define %minimum-disk-space + ;; Minimum disk space required on the build machine for a build to be + ;; offloaded. This keeps us from offloading to machines that are bound to + ;; run out of disk space. + (* 100 (expt 2 20))) ;100 MiB + +(define (node-load node) + "Return the load on NODE. Return +∞ if NODE is misbehaving." + (let ((line (inferior-eval '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string)) + node))) + (if (eof-object? line) + +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + (match (string-tokenize line) + ((one five fifteen . x) + (string->number one)) + (x + +inf.0))))) + +(define (normalized-load machine load) + "Divide LOAD by the number of parallel builds of MACHINE." + (if (rational? load) + (let* ((jobs (build-machine-parallel-builds machine)) + (normalized (/ load jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ (normalized: ~s)~%" - (build-machine-name machine) raw normalized) - normalized)) - (x - +inf.0))))) ;something's fishy about MACHINE, so avoid it - (x - +inf.0))) ;failed to connect to MACHINE, so avoid it - -(define (machine-lock-file machine hint) - "Return the name of MACHINE's lock file for HINT." - (string-append %state-directory "/offload/" - (build-machine-name machine) - "." (symbol->string hint) ".lock")) - -(define (machine-choice-lock-file) - "Return the name of the file used as a lock when choosing a build machine." - (string-append %state-directory "/offload/machine-choice.lock")) + (build-machine-name machine) load normalized) + normalized) + load)) (define (random-seed) (logxor (getpid) (car (gettimeofday)))) @@ -452,41 +464,44 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Proceed like this: - ;; 1. Acquire the global machine-choice lock. - ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out + ;; 1. For all MACHINES, attempt to acquire a build slot, and filter out ;; those machines for which we failed. - ;; 3. Choose the best machine among those that are left. - ;; 4. Release the previously-acquired build slots of the other machines. - ;; 5. Release the global machine-choice lock. - - (with-file-lock (machine-choice-lock-file) - (define machines+slots - (filter-map (lambda (machine) - (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) - (shuffle machines))) - - (define (undecorate pred) - (lambda (a b) - (match a - ((machine1 slot1) - (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (define (machine-faster? m1 m2) - ;; Return #t if M1 is faster than M2. - (> (build-machine-speed m1) - (build-machine-speed m2))) - - (let loop ((machines+slots - (sort machines+slots (undecorate machine-faster?)))) - (match machines+slots - (((best slot) others ...) - ;; Return the best machine unless it's already overloaded. - ;; Note: We call 'machine-load' only as a last resort because it is - ;; too costly to call it once for every machine. - (if (< (machine-load best) 2.) + ;; 2. Choose the best machine among those that are left. + ;; 3. Release the previously-acquired build slots of the other machines. + + (define machines+slots + (filter-map (lambda (machine) + (let ((slot (acquire-build-slot machine))) + (and slot (list machine slot)))) + (shuffle machines))) + + (define (undecorate pred) + (lambda (a b) + (match a + ((machine1 slot1) + (match b + ((machine2 slot2) + (pred machine1 machine2))))))) + + (define (machine-faster? m1 m2) + ;; Return #t if M1 is faster than M2. + (> (build-machine-speed m1) + (build-machine-speed m2))) + + (let loop ((machines+slots + (sort machines+slots (undecorate machine-faster?)))) + (match machines+slots + (((best slot) others ...) + ;; Return the best machine unless it's already overloaded. + ;; Note: We call 'node-load' only as a last resort because it is + ;; too costly to call it once for every machine. + (let* ((session (false-if-exception (open-ssh-session best))) + (node (and session (remote-inferior session))) + (load (and node (normalized-load best (node-load node)))) + (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) + (when session (disconnect! session)) + (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others (((machines slots) ...) ;; Release slots from the uninteresting machines. @@ -496,11 +511,17 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; eventually release it. (values best slot))) (begin - ;; BEST is overloaded, so try the next one. + ;; BEST is unsuitable, so try the next one. + (when (and space (< space %minimum-disk-space)) + (format (current-error-port) + "skipping machine '~a' because it is low \ +on disk space (~,2f MiB free)~%" + (build-machine-name best) + (/ space (expt 2 20) 1.))) (release-build-slot slot) - (loop others)))) - (() - (values #f #f)))))) + (loop others))))) + (() + (values #f #f))))) (define (call-with-timeout timeout drv thunk) "Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call @@ -581,40 +602,34 @@ If TIMEOUT is #f, simply evaluate EXP..." (#f (report-guile-error name)) ((? string? version) - ;; Note: The version string already contains the word "Guile". - (info (G_ "'~a' is running ~a~%") + (info (G_ "'~a' is running GNU Guile ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) - "Bail out if NODE lacks the (guix) module, or if its daemon is not running." - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + "Bail out if NODE if #f or if we fail to use the (guix) module, or if its +daemon is not running." + (unless (inferior? node) + (leave (G_ "failed to run 'guix repl' on '~a'~%") name)) + + (match (inferior-eval '(begin (use-modules (guix)) - (and add-text-to-store 'alright))) - ('alright #t) - (_ (report-module-error name)))) - (lambda (key . args) - (report-module-error name))) + (and add-text-to-store 'alright)) + node) + ('alright #t) + (_ (report-module-error name))) - (catch 'node-repl-error - (lambda () - (match (node-eval node - '(begin + (match (inferior-eval '(begin (use-modules (guix)) (with-store store (add-text-to-store store "test" - "Hello, build machine!")))) - ((? string? str) - (info (G_ "Guix is usable on '~a' (test returned ~s)~%") - name str)) - (x - (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") - name x)))) - (lambda (key . args) - (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") - name args)))) + "Hello, build machine!"))) + node) + ((? string? str) + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") + name x)))) (define %random-state (delay @@ -624,25 +639,23 @@ If TIMEOUT is #f, simply evaluate EXP..." (string-append name "-" (number->string (random 1000000 (force %random-state))))) -(define (assert-node-can-import node name daemon-socket) +(define (assert-node-can-import session node name daemon-socket) "Bail out if NODE refuses to import our archives." - (let ((session (node-session node))) - (with-store store - (let* ((item (add-text-to-store store "export-test" (nonce))) - (remote (connect-to-remote-daemon session daemon-socket))) - (with-store local - (send-files local (list item) remote)) - - (if (valid-path? remote item) - (info (G_ "'~a' successfully imported '~a'~%") - name item) - (leave (G_ "'~a' was not properly imported on '~a'~%") - item name)))))) - -(define (assert-node-can-export node name daemon-socket) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) + + (if (valid-path? remote item) + (info (G_ "'~a' successfully imported '~a'~%") + name item) + (leave (G_ "'~a' was not properly imported on '~a'~%") + item name))))) + +(define (assert-node-can-export session node name daemon-socket) "Bail out if we cannot import signed archives from NODE." - (let* ((session (node-session node)) - (remote (connect-to-remote-daemon session daemon-socket)) + (let* ((remote (connect-to-remote-daemon session daemon-socket)) (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store (if (and (retrieve-files store (list item) remote) @@ -669,11 +682,13 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map open-ssh-session machines)) - (nodes (map make-node sessions))) - (for-each assert-node-repl nodes names) + (nodes (map remote-inferior sessions))) (for-each assert-node-has-guix nodes names) - (for-each assert-node-can-import nodes names sockets) - (for-each assert-node-can-export nodes names sockets)))) + (for-each assert-node-repl nodes names) + (for-each assert-node-can-import sessions nodes names sockets) + (for-each assert-node-can-export sessions nodes names sockets) + (for-each close-inferior nodes) + (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) "Print the load of each machine matching PRED in MACHINE-FILE." @@ -689,16 +704,41 @@ machine." (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((node (make-node (open-ssh-session machine))) - (uts (node-eval node '(uname)))) - (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ - host name: ~a~% normalized load: ~a~%" - (build-machine-name machine) - (utsname:sysname uts) (utsname:release uts) - (utsname:machine uts) - (utsname:nodename uts) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (machine-load machine))))) + (define session + (open-ssh-session machine)) + + (match (remote-inferior session) + (#f + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (build-machine-name machine))) + ((? inferior? inferior) + (let ((now (car (gettimeofday)))) + (match (inferior-eval '(list (uname) + (car (gettimeofday))) + inferior) + ((uts time) + (when (< time now) + ;; Build machine clocks must not be behind as this + ;; could cause timestamp issues. + (warning (G_ "machine '~a' is ~a seconds behind~%") + (build-machine-name machine) + (- now time))) + + (let ((load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%\ + time difference: ~a s~%" + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (normalized-load machine load) + (/ free (expt 2 20) 1.) + (- time now)))))))) + + (disconnect! session)) machines))) @@ -789,7 +829,6 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (leave (G_ "invalid arguments: ~{~s ~}~%") x)))) ;;; Local Variables: -;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) ;;; eval: (put 'with-file-lock 'scheme-indent-function 1) ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 2) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6c6680ab58..40e59a6101 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> @@ -553,9 +553,7 @@ please email '~a'~%") "run.c" "-o" result) (delete-file "run.c"))) - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) - (else _IOLBF))) + (setvbuf (current-output-port) 'line) ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. @@ -600,7 +598,8 @@ please email '~a'~%") (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . 2) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -687,6 +686,11 @@ please email '~a'~%") (alist-cons 'profile-name arg result)) (_ (leave (G_ "~a: unsupported profile name~%") arg))))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -725,6 +729,8 @@ Create a bundle of PACKAGE.\n")) --profile-name=NAME populate /var/guix/profiles/.../NAME")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) (display (G_ " @@ -774,7 +780,7 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5743816324..8a71467b52 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.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 © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -120,21 +120,21 @@ denote ranges as interpreted by 'matching-generations'." (define* (build-and-use-profile store profile manifest #:key + (hooks %default-profile-hooks) allow-collisions? bootstrap? use-substitutes? dry-run?) "Build a new generation of PROFILE, a file name, using the packages specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, -do not treat collisions in MANIFEST as an error." +do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile +hooks\" run when building the profile." (when (equal? profile %current-profile) (ensure-default-profile)) (let* ((prof-drv (run-with-store store (profile-derivation manifest #:allow-collisions? allow-collisions? - #:hooks (if bootstrap? - '() - %default-profile-hooks) + #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) @@ -220,31 +220,32 @@ of relevance scores." ('dismiss transaction) (($ <manifest-entry> name version output (? string? path)) - (match (vhash-assoc name (find-newest-available-packages)) - ((_ candidate-version pkg . rest) - (match (package-superseded pkg) - ((? package? new) - (supersede entry new)) - (#f - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (string=? path candidate-path) - (null? (package-propagated-inputs pkg))) - transaction - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)))))))) - (#f + (match (find-best-packages-by-name name #f) + ((pkg . rest) + (let ((candidate-version (package-version pkg))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? path candidate-path) + (null? (package-propagated-inputs pkg))) + transaction + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction))))))))) + (() (warning (G_ "package '~a' no longer exists~%") name) transaction))))) @@ -293,7 +294,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (define %default-options ;; Alist of default option values. - `((verbosity . 0) + `((verbosity . 1) + (debug . 0) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -346,7 +348,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) (display (G_ " - --verbose produce verbose output")) + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -s, --search=REGEXP search in synopsis and description using REGEXP")) @@ -472,13 +474,21 @@ kind of search path~%") (values (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)) #f))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result arg-handler) + (let ((level (string->number* arg))) + (values (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + #f)))) (option '("bootstrap") #f #f (lambda (opt name arg result arg-handler) (values (alist-cons 'bootstrap? #t result) #f))) - (option '("verbose") #f #f + (option '("verbose") #f #f ;deprecated (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) + (values (alist-cons 'verbosity 2 + (alist-delete 'verbosity + result)) #f))) (option '("allow-collisions") #f #f (lambda (opt name arg result arg-handler) @@ -595,12 +605,12 @@ and upgrades." (options->upgrade-predicate opts)) (define upgraded - (fold-right (lambda (entry transaction) - (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) - transaction)) - transaction - (manifest-entries manifest))) + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -726,29 +736,34 @@ processed, #f otherwise." (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (and (supported-package? p) - (not (package-superseded p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) + (available (fold-available-packages + (lambda* (name version result + #:key outputs location + supported? deprecated? + #:allow-other-keys) + (if (and supported? (not deprecated?)) + (if regexp + (if (regexp-exec regexp name) + (cons `(,name ,version + ,outputs ,location) + result) + result) + (cons `(,name ,version + ,outputs ,location) + result)) + result)) '()))) (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) + (for-each (match-lambda + ((name version outputs location) + (format #t "~a\t~a\t~a\t~a~%" + name version + (string-join outputs ",") + (location->string location)))) (sort available - (lambda (p1 p2) - (string<? (package-name p1) - (package-name p2)))))) + (match-lambda* + (((name1 . _) (name2 . _)) + (string<? name1 name2)))))) #t)) (('search _) @@ -907,14 +922,12 @@ processed, #f otherwise." (define opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) - (define verbose? - (assoc-ref opts 'verbose?)) (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) (%graft? (assoc-ref opts 'graft?))) - (with-status-report print-build-event/quiet + (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index dc83729911..683ab3f059 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -34,17 +34,19 @@ #:use-module (guix channels) #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) + #:autoload (guix build utils) (which) #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) #:use-module ((guix scripts package) #:select (build-and-use-profile)) - #:use-module (gnu packages base) + #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) @@ -66,7 +68,8 @@ (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 1))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... @@ -89,6 +92,10 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " -n, --dry-run show what would be pulled and built")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) (show-build-options-help) @@ -120,15 +127,23 @@ Download and deploy the latest version of Guix.\n")) (alist-cons 'ref `(commit . ,arg) result))) (option '("branch") #t #f (lambda (opt name arg result) - (alist-cons 'ref `(branch . ,(string-append "origin/" arg)) - result))) + (alist-cons 'ref `(branch . ,arg) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -175,9 +190,21 @@ true, display what would be built without actually building it." (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest + #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)))))) + (return (display-profile-news profile)) + (match (which "guix") + (#f (return #f)) + (str + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + (unless (member str new) + (display-hint (format #f (G_ "After setting @code{PATH}, run +@command{hash guix} to make sure your shell refers to @file{~a}.") + (first new)))) + (return #f)))))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -504,8 +531,9 @@ Use '~/.config/guix/channels.scm' instead.")) (process-query opts profile)) (else (with-store store - (with-status-report print-build-event - (parameterize ((%graft? (assoc-ref opts 'graft?)) + (with-status-verbosity (assoc-ref opts 'verbosity) + (parameterize ((%current-system (assoc-ref opts 'system)) + (%graft? (assoc-ref opts 'graft?)) (%repository-cache-directory cache)) (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 1d86f949c8..5b0f345cde 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,10 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -88,6 +90,12 @@ (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) + (option '("list-transitive") #f #f + (lambda (opt name arg result) + (alist-cons 'list-transitive? #t result))) (option '("keyring") #t #f (lambda (opt name arg result) @@ -140,6 +148,10 @@ specified with `--select'.\n")) (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) + (display (G_ " + -r, --recursive check the PACKAGE and its inputs for upgrades")) + (display (G_ " + --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) @@ -160,6 +172,79 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) +(define (options->packages opts) + "Return the list of packages requested by OPTS, honoring options like +'--recursive'." + (define core-package? + (let* ((input->package (match-lambda + ((name (? package? package) _ ...) package) + (_ #f))) + (final-inputs (map input->package %final-inputs)) + (core (append final-inputs + (append-map (compose (cut filter-map input->package <>) + package-transitive-inputs) + final-inputs))) + (names (delete-duplicates (map package-name core)))) + (lambda (package) + "Return true if PACKAGE is likely a \"core package\"---i.e., one whose +update would trigger a complete rebuild." + ;; Compare by name because packages in base.scm basically inherit + ;; other packages. So, even if those packages are not core packages + ;; themselves, updating them would also update those who inherit from + ;; them. + ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. + (member (package-name package) names)))) + + (define (keep-newest package lst) + ;; If a newer version of PACKAGE is already in LST, return LST; otherwise + ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. + (let ((name (package-name package))) + (match (find (lambda (p) + (string=? (package-name p) name)) + lst) + ((? package? other) + (if (version>? (package-version other) (package-version package)) + lst + (cons package (delq other lst)))) + (_ + (cons package lst))))) + + (define args-packages + ;; Packages explicitly passed as command-line arguments. + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts) + (() ;default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '()))) + (some ;user-specified packages + some))) + + (define packages + (match (assoc-ref opts 'manifest) + (#f args-packages) + ((? string? file) (packages-from-manifest file)))) + + (if (assoc-ref opts 'recursive?) + (mlet %store-monad ((edges (node-edges %bag-node-type + (all-packages)))) + (return (node-transitive-edges packages edges))) + (with-monad %store-monad + (return packages)))) + ;;; ;;; Updates. @@ -212,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball) + (let-values (((version tarball changes) (package-update store package updaters #:key-download key-download)) ((loc) @@ -226,6 +311,26 @@ warn about packages that have no matching updater." (location->string loc) (package-name package) (package-version package) version) + (for-each + (lambda (change) + (format (current-error-port) + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (G_ "~a: consider adding this input: ~a~%")) + (('add 'native) + (G_ "~a: consider adding this native input: ~a~%")) + (('add 'propagated) + (G_ "~a: consider adding this propagated input: ~a~%")) + (('remove 'regular) + (G_ "~a: consider removing this input: ~a~%")) + (('remove 'native) + (G_ "~a: consider removing this native input: ~a~%")) + (('remove 'propagated) + (G_ "~a: consider removing this propagated input: ~a~%"))) + (package-name package) + (upstream-input-change-name change))) + (changes)) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) @@ -295,7 +400,7 @@ the latest known version of ~a (~a)~%") (package-version package))) (mlet %store-monad ((edges (node-back-edges %bag-node-type - (all-packages)))) + (package-closure (all-packages))))) (let* ((dependents (node-transitive-edges packages edges)) (covering (filter (lambda (node) (null? (edges node))) @@ -314,8 +419,8 @@ the latest known version of ~a (~a)~%") (full-name x))) (lst (format (current-output-port) - (N_ "Building the following package would ensure ~d \ -dependent packages are rebuilt: ~*~{~a~^ ~}~%" + (N_ "Building the following ~*package would ensure ~d \ +dependent packages are rebuilt: ~{~a~^ ~}~%" "Building the following ~d packages would ensure ~d \ dependent packages are rebuilt: ~{~a~^ ~}~%" (length covering)) @@ -323,6 +428,30 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) +(define (list-transitive packages) + "List all the packages that would cause PACKAGES to be rebuilt if they are changed." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + (match packages + ((x) + (format (current-output-port) + (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") + (full-name x) (length dependent) (map full-name dependent))) + (lst + (format (current-output-port) + (G_ "The following ~d packages \ +all are dependent packages: ~{~a~^ ~}~%") + (length dependent) (map full-name dependent)))) + (return #t)))) + ;;; ;;; Manifest. @@ -365,103 +494,48 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (lists (concatenate lists)))) - (define (keep-newest package lst) - ;; If a newer version of PACKAGE is already in LST, return LST; otherwise - ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. - (let ((name (package-name package))) - (match (find (lambda (p) - (string=? (package-name p) name)) - lst) - ((? package? other) - (if (version>? (package-version other) (package-version package)) - lst - (cons package (delq other lst)))) - (_ - (cons package lst))))) - - (define core-package? - (let* ((input->package (match-lambda - ((name (? package? package) _ ...) package) - (_ #f))) - (final-inputs (map input->package %final-inputs)) - (core (append final-inputs - (append-map (compose (cut filter-map input->package <>) - package-transitive-inputs) - final-inputs))) - (names (delete-duplicates (map package-name core)))) - (lambda (package) - "Return true if PACKAGE is likely a \"core package\"---i.e., one whose -update would trigger a complete rebuild." - ;; Compare by name because packages in base.scm basically inherit - ;; other packages. So, even if those packages are not core packages - ;; themselves, updating them would also update those who inherit from - ;; them. - ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. - (member (package-name package) names)))) - (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) + (recursive? (assoc-ref opts 'recursive?)) (list-dependent? (assoc-ref opts 'list-dependent?)) + (list-transitive? (assoc-ref opts 'list-transitive?)) (key-download (assoc-ref opts 'key-download)) ;; Warn about missing updaters when a package is explicitly given on ;; the command line. - (warn? (or (assoc-ref opts 'argument) - (assoc-ref opts 'expression))) - (args-packages - (match (filter-map (match-lambda - (('argument . spec) - ;; Take either the specified version or the - ;; latest one. - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some))) - (packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file))))) + (warn? (and (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression) + (assoc-ref opts 'manifest)) + (not recursive?)))) (with-error-handling (with-store store (run-with-store store - (cond - (list-dependent? - (list-dependents packages)) - (update? - (parameterize ((%openpgp-key-server - (or (assoc-ref opts 'key-server) - (%openpgp-key-server))) - (%gpg-command - (or (assoc-ref opts 'gpg-command) - (%gpg-command))) - (current-keyring - (or (assoc-ref opts 'keyring) - (string-append (config-directory) - "/upstream/trustedkeys.kbx")))) - (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) - (with-monad %store-monad - (return #t)))) - (else - (for-each (cut check-for-package-update <> updaters - #:warn? warn?) - packages) - (with-monad %store-monad + (mlet %store-monad ((packages (options->packages opts))) + (cond + (list-dependent? + (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (update? + (parameterize ((%openpgp-key-server + (or (assoc-ref opts 'key-server) + (%openpgp-key-server))) + (%gpg-command + (or (assoc-ref opts 'gpg-command) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) + (for-each + (cut update-package store <> updaters + #:key-download key-download + #:warn? warn?) + packages) + (return #t))) + (else + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) + packages) (return #t))))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 53b1777241..797a76db3f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; @@ -219,7 +219,7 @@ provide." (set! port (guix:open-connection-for-uri uri #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) - (setvbuf port _IONBF))) + (setvbuf port 'none))) (http-fetch uri #:text? #f #:port port #:verify-certificate? #f)))))) (else @@ -567,7 +567,7 @@ initial connection on which HTTP requests are sent." verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) - (setvbuf p _IOFBF (expt 2 16))) + (setvbuf p 'block (expt 2 16))) ;; Send REQUESTS, up to a certain number, in a row. ;; XXX: Do our own caching to work around inefficiencies when diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6cda3ccbd6..569b826acd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -1015,6 +1015,8 @@ Some ACTIONS support additional ARGS.\n")) --full-boot for 'vm', make a full boot sequence")) (display (G_ " --skip-checks skip file system and initrd module safety checks")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -1074,6 +1076,11 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -1092,7 +1099,8 @@ Some ACTIONS support additional ARGS.\n")) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . #f) ;default (file-system-type . "ext4") (image-size . guess) (install-bootloader? . #t))) @@ -1267,9 +1275,9 @@ argument list and OPTS is the option alist." (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-report (if (memq command '(init reconfigure)) - print-build-event/quiet - print-build-event) + (with-status-verbosity (or (assoc-ref opts 'verbosity) + (if (memq command '(init reconfigure)) + 1 2)) (process-command command args opts)))))) ;;; Local Variables: diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 98b7338fb9..4b12f9550e 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; @@ -32,6 +32,9 @@ #:use-module (guix scripts substitute) #:use-module (guix http-client) #:use-module (guix ci) + #:use-module (guix sets) + #:use-module (guix graph) + #:autoload (guix scripts graph) (%bag-node-type) #:use-module (gnu packages) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -41,6 +44,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 vlist) #:export (guix-weather)) (define (all-packages) @@ -51,7 +55,10 @@ (cons* replacement package result)) (#f (cons package result)))) - '())) + '() + + ;; Dismiss deprecated packages but keep hidden packages. + #:select? (negate package-superseded))) (define (call-with-progress-reporter reporter proc) "This is a variant of 'call-with-progress-reporter' that works with monadic @@ -254,6 +261,10 @@ Report the availability of substitutes.\n")) -m, --manifest=MANIFEST look up substitutes for packages specified in MANIFEST")) (display (G_ " + -c, --coverage[=COUNT] + show substitute coverage for packages with at least + COUNT dependents")) + (display (G_ " -s, --system=SYSTEM consider substitutes for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " @@ -286,6 +297,11 @@ Report the availability of substitutes.\n")) (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) + (option '(#\c "coverage") #f #t + (lambda (opt name arg result) + (alist-cons 'coverage + (if arg (string->number* arg) 0) + result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg result))))) @@ -302,6 +318,153 @@ Report the availability of substitutes.\n")) ;;; +;;; Missing package substitutes. +;;; + +(define* (package-partition-boundary pred packages + #:key (system (%current-system))) + "Return the subset of PACKAGES that are at the \"boundary\" between those +that match PRED and those that don't. The returned packages themselves do not +match PRED but they have at least one direct dependency that does. + +Note: The assumption is that, if P matches PRED, then all the dependencies of +P match PRED as well." + ;; XXX: Graph theoreticians surely have something to teach us about this... + (let loop ((packages packages) + (result (setq)) + (visited vlist-null)) + (define (visited? package) + (vhash-assq package visited)) + + (match packages + ((package . rest) + (cond ((visited? package) + (loop rest result visited)) + ((pred package) + (loop rest result (vhash-consq package #t visited))) + (else + (let* ((bag (package->bag package system)) + (deps (filter-map (match-lambda + ((label (? package? package) . _) + (and (not (pred package)) + package)) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append deps rest) + (if (null? deps) + (set-insert package result) + result) + (vhash-consq package #t visited)))))) + (() + (set->list result))))) + +(define (package->output-mapping packages system) + "Return a vhash that maps each item of PACKAGES to its corresponding output +store file names for SYSTEM." + (foldm %store-monad + (lambda (package mapping) + (mlet %store-monad ((drv (package->derivation package system + #:graft? #f))) + (return (vhash-consq package + (match (derivation->output-paths drv) + (((names . outputs) ...) + outputs)) + mapping)))) + vlist-null + packages)) + +(define (substitute-oracle server items) + "Return a procedure that, when passed a store item (one of those listed in +ITEMS), returns true if SERVER has a substitute for it, false otherwise." + (define available + (fold (lambda (narinfo set) + (set-insert (narinfo-path narinfo) set)) + (set) + (lookup-narinfos server items))) + + (cut set-contains? available <>)) + +(define* (report-package-coverage-per-system server packages system + #:key (threshold 0)) + "Report on the subset of PACKAGES that lacks SYSTEM substitutes on SERVER, +sorted by decreasing number of dependents. Do not display those with less +than THRESHOLD dependents." + (mlet* %store-monad ((packages -> (package-closure packages #:system system)) + (mapping (package->output-mapping packages system)) + (back-edges (node-back-edges %bag-node-type packages))) + (define items + (vhash-fold (lambda (package items result) + (append items result)) + '() + mapping)) + + (define substitutable? + (substitute-oracle server items)) + + (define substitutable-package? + (lambda (package) + (match (vhash-assq package mapping) + ((_ . items) + (find substitutable? items)) + (#f + #f)))) + + (define missing + (package-partition-boundary substitutable-package? packages + #:system system)) + + (define missing-count + (length missing)) + + (if (zero? threshold) + (format #t (N_ "The following ~a package is missing from '~a' for \ +'~a':~%" + "The following ~a packages are missing from '~a' for \ +'~a':~%" + missing-count) + missing-count server system) + (format #t (N_ "~a package is missing from '~a' for '~a':~%" + "~a packages are missing from '~a' for '~a', among \ +which:~%" + missing-count) + missing-count server system)) + + (for-each (match-lambda + ((package count) + (match (vhash-assq package mapping) + ((_ . items) + (when (>= count threshold) + (format #t " ~4d\t~a@~a\t~{~a ~}~%" + count + (package-name package) (package-version package) + items))) + (#f ;PACKAGE must be an internal thing + #f)))) + (sort (zip missing + (map (lambda (package) + (node-reachable-count (list package) + back-edges)) + missing)) + (match-lambda* + (((_ count1) (_ count2)) + (< count2 count1))))) + (return #t))) + +(define* (report-package-coverage server packages systems + #:key (threshold 0)) + "Report on the substitute coverage for PACKAGES, for each of SYSTEMS, on +SERVER. Display information for packages with at least THRESHOLD dependents." + (with-store store + (run-with-store store + (foldm %store-monad + (lambda (system _) + (report-package-coverage-per-system server packages system + #:threshold threshold)) + #f + systems)))) + + +;;; ;;; Entry point. ;;; @@ -331,7 +494,12 @@ Report the availability of substitutes.\n")) (package-outputs packages system)) systems))))))) (for-each (lambda (server) - (report-server-coverage server items)) + (report-server-coverage server items) + (match (assoc-ref opts 'coverage) + (#f #f) + (threshold + (report-package-coverage server packages systems + #:threshold threshold)))) urls))))) ;;; Local Variables: diff --git a/guix/self.scm b/guix/self.scm index f2db3dbf52..a45470a0a6 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,47 +31,18 @@ #:use-module ((guix build compile) #:select (%lightweight-optimizations)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (make-config.scm whole-package ;for internal use in 'guix pull' compiled-guix - guix-derivation - reload-guix)) + guix-derivation)) ;;; ;;; Dependency handling. ;;; -(define* (false-if-wrong-guile package - #:optional (guile-version (effective-version))) - "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., -2.0 instead of 2.2), otherwise return PACKAGE." - (let ((guile (any (match-lambda - ((label (? package? dep) _ ...) - (and (string=? (package-name dep) "guile") - dep))) - (package-direct-inputs package)))) - (and (or (not guile) - (string-prefix? guile-version - (package-version guile))) - package))) - -(define (package-for-guile guile-version . names) - "Return the package with one of the given NAMES that depends on -GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." - (let loop ((names names)) - (match names - (() - #f) - ((name rest ...) - (match (specification->package name) - (#f - (loop rest)) - ((? package? package) - (or (false-if-wrong-guile package guile-version) - (loop rest)))))))) - (define specification->package ;; Use our own variant of that procedure because that of (gnu packages) ;; would traverse all the .scm files, which is wasteful. @@ -89,12 +60,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) - ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) - ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) - ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) - ;; XXX: No "guile2.0-sqlite3". - ("guile2.0-gnutls" (ref '(gnu packages tls) 'gnutls/guile-2.0)) - (_ #f)))) ;no such package + (_ #f)))) ;no such package ;;; @@ -133,6 +99,30 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." #:name (file-mapping-name mapping) #:system system)) +(define (node-source+compiled node) + "Return a \"bundle\" containing both the source code and object files for +NODE's modules, under their FHS directories: share/guile/site and lib/guile." + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define source + (string-append #$output "/share/guile/site/" + (effective-version))) + + (define object + (string-append #$output "/lib/guile/" (effective-version) + "/site-ccache")) + + (mkdir-p (dirname source)) + (symlink #$(node-source node) source) + (mkdir-p (dirname object)) + (symlink #$(node-compiled node) object)))) + + (computed-file (string-append (node-name node) "-modules") + build)) + (define (node-fold proc init nodes) (let loop ((nodes nodes) (visited (setq)) @@ -360,40 +350,64 @@ DOMAIN, a gettext domain." (basename texi ".texi") ".info"))) (cons "guix.texi" - (find-files "." "^guix\\.[a-z]{2}\\.texi$")))))) + (find-files "." "^guix\\.[a-z]{2}\\.texi$"))) + + ;; Compress Info files. + (setenv "PATH" + #+(file-append (specification->package "gzip") "/bin")) + (for-each (lambda (file) + (invoke "gzip" "-9n" file)) + (find-files #$output "\\.info(-[0-9]+)?$"))))) (computed-file "guix-manual" build)) -(define* (guix-command modules #:optional compiled-modules +(define* (guile-module-union things #:key (name "guix-module-union")) + "Return the union of the subset of THINGS (packages, computed files, etc.) +that provide Guile modules." + (define build + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + + (define (modules directory) + (string-append directory "/share/guile/site")) + + (define (objects directory) + (string-append directory "/lib/guile")) + + (union-build #$output + (filter (lambda (directory) + (or (file-exists? (modules directory)) + (file-exists? (objects directory)))) + '#$things) + + #:log-port (%make-void-port "w"))))) + + (computed-file name build)) + +(define* (guix-command modules #:key source (dependencies '()) guile (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." - (define source-directories - (map (lambda (package) - (file-append package "/share/guile/site/" - guile-version)) - dependencies)) - - (define object-directories - (map (lambda (package) - (file-append package "/lib/guile/" - guile-version "/site-ccache")) - dependencies)) + (define module-directory + ;; To minimize the number of 'stat' calls needed to locate a module, + ;; create the union of all the module directories. + (guile-module-union (cons modules dependencies))) (program-file "guix-command" #~(begin (set! %load-path - (append (filter file-exists? '#$source-directories) - %load-path)) + (cons (string-append #$module-directory + "/share/guile/site/" + (effective-version)) + %load-path)) (set! %load-compiled-path - (append (filter file-exists? '#$object-directories) - %load-compiled-path)) - - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons (or #$compiled-modules #$modules) + (cons (string-append #$module-directory + "/lib/guile/" + (effective-version) + "/site-ccache") %load-compiled-path)) (let ((guix-main (module-ref (resolve-interface '(guix ui)) @@ -436,7 +450,6 @@ load path." (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) - compiled-modules info daemon miscellany guile (command (guix-command modules @@ -444,51 +457,54 @@ load path." #:guile guile #:guile-version guile-version))) "Return the whole Guix package NAME that uses MODULES, a derivation of all -the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the -'guix' program to use; INFO is the Info manual. When COMPILED-MODULES is -true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are -assumed to be part of MODULES." +the modules (under share/guile/site and lib/guile), and DEPENDENCIES, a list +of packages depended on. COMMAND is the 'guix' program to use; INFO is the +Info manual." + (define (wrap daemon) + (program-file "guix-daemon" + #~(begin + (setenv "GUIX" #$command) + (apply execl #$(file-append daemon "/bin/guix-daemon") + "guix-daemon" (cdr (command-line)))))) + (computed-file name (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) + (define daemon + #$(and daemon (wrap daemon))) + (mkdir-p (string-append #$output "/bin")) (symlink #$command (string-append #$output "/bin/guix")) - (when #$daemon - (symlink (string-append #$daemon "/bin/guix-daemon") + (when daemon + (symlink daemon (string-append #$output "/bin/guix-daemon"))) - (let ((modules (string-append #$output - "/share/guile/site/" - (effective-version))) - (info #$info)) - (mkdir-p (dirname modules)) - (symlink #$modules modules) + (let ((share (string-append #$output "/share")) + (lib (string-append #$output "/lib")) + (info #$info)) + (mkdir-p share) + (symlink #$(file-append modules "/share/guile") + (string-append share "/guile")) (when info - (symlink #$info - (string-append #$output - "/share/info")))) + (symlink #$info (string-append share "/info"))) + + (mkdir-p lib) + (symlink #$(file-append modules "/lib/guile") + (string-append lib "/guile"))) (when #$miscellany (copy-recursively #$miscellany #$output - #:log (%make-void-port "w"))) - - ;; Object files. - (when #$compiled-modules - (let ((modules (string-append #$output "/lib/guile/" - (effective-version) - "/site-ccache"))) - (mkdir-p (dirname modules)) - (symlink #$compiled-modules modules))))))) + #:log (%make-void-port "w"))))))) (define* (compiled-guix source #:key (version %guix-version) (pull-version 1) (name (string-append "guix-" version)) (guile-version (effective-version)) - (guile-for-build (guile-for-build guile-version)) + (guile-for-build (default-guile)) (zlib (specification->package "zlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) @@ -496,32 +512,22 @@ assumed to be part of MODULES." (guix (specification->package "guix"))) "Return a file-like object that contains a compiled Guix." (define guile-json - (package-for-guile guile-version - "guile-json" - "guile2.0-json")) + (specification->package "guile-json")) (define guile-ssh - (package-for-guile guile-version - "guile-ssh" - "guile2.0-ssh")) + (specification->package "guile-ssh")) (define guile-git - (package-for-guile guile-version - "guile-git" - "guile2.0-git")) + (specification->package "guile-git")) (define guile-sqlite3 - (package-for-guile guile-version - "guile-sqlite3" - "guile2.0-sqlite3")) + (specification->package "guile-sqlite3")) (define guile-gcrypt - (package-for-guile guile-version - "guile-gcrypt")) + (specification->package "guile-gcrypt")) (define gnutls - (package-for-guile guile-version - "gnutls" "guile2.0-gnutls")) + (specification->package "gnutls")) (define dependencies (match (append-map (lambda (package) @@ -616,6 +622,9 @@ assumed to be part of MODULES." (append (file-imports source "gnu/system/examples" (const #t)) + ;; All the installer code is on the build-side. + (file-imports source "gnu/installer/" + (const #t)) ;; Build-side code that we don't build. Some of ;; these depend on guile-rsvg, the Shepherd, etc. (file-imports source "gnu/build" (const #t))) @@ -624,13 +633,25 @@ assumed to be part of MODULES." (define *cli-modules* (scheme-node "guix-cli" - (scheme-modules* source "/guix/scripts") + (append (scheme-modules* source "/guix/scripts") + `((gnu ci))) (list *core-modules* *extra-modules* *core-package-modules* *package-modules* *system-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) + (define *system-test-modules* + ;; Ship these modules mostly so (gnu ci) can discover them. + (scheme-node "guix-system-tests" + `((gnu tests) + ,@(scheme-modules* source "gnu/tests")) + (list *core-package-modules* *package-modules* + *extra-modules* *system-modules* *core-modules* + *cli-modules*) ;for (guix scripts pack), etc. + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *config* (scheme-node "guix-config" '() @@ -659,6 +680,7 @@ assumed to be part of MODULES." ;; comes with *CORE-MODULES*. (list *config* *cli-modules* + *system-test-modules* *system-modules* *package-modules* *core-package-modules* @@ -680,15 +702,13 @@ assumed to be part of MODULES." ;; Version 1 is when we return the full package. (cond ((= 1 pull-version) ;; The whole package, with a standard file hierarchy. - (let* ((modules (built-modules (compose list node-source))) - (compiled (built-modules (compose list node-compiled))) - (command (guix-command modules compiled + (let* ((modules (built-modules (compose list node-source+compiled))) + (command (guix-command modules #:source source #:dependencies dependencies #:guile guile-for-build #:guile-version guile-version))) (whole-package name modules dependencies - #:compiled-modules compiled #:command command #:guile guile-for-build @@ -776,11 +796,11 @@ assumed to be part of MODULES." (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in ;; `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory @@ -810,7 +830,6 @@ assumed to be part of MODULES." ;; made relative to a nonexistent anonymous module. #:splice? #t)) - ;;; ;;; Building. @@ -847,13 +866,23 @@ containing MODULE-FILES and possibly other files as well." (define (report-load file total completed) (display #\cr) (format #t - "loading...\t~5,1f% of ~d files" ;FIXME: i18n + "[~3@a/~3@a] loading...\t~5,1f% of ~d files" + + ;; Note: Multiply TOTAL by two to account for the + ;; compilation phase that follows. + completed (* total 2) + (* 100. (/ completed total)) total) (force-output)) (define (report-compilation file total completed) (display #\cr) - (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (format #t "[~3@a/~3@a] compiling...\t~5,1f% of ~d files" + + ;; Add TOTAL to account for the load phase that came + ;; before. + (+ total completed) (* total 2) + (* 100. (/ completed total)) total) (force-output)) @@ -865,8 +894,8 @@ containing MODULE-FILES and possibly other files as well." #:report-load report-load #:report-compilation report-compilation))) - (setvbuf (current-output-port) _IONBF) - (setvbuf (current-error-port) _IONBF) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) (set! %load-path (cons #+module-tree %load-path)) (set! %load-path @@ -911,21 +940,6 @@ containing MODULE-FILES and possibly other files as well." ;;; Building. ;;; -(define (guile-for-build version) - "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently -running Guile." - (define canonical-package ;soft reference - (module-ref (resolve-interface '(gnu packages base)) - 'canonical-package)) - - (match version - ("2.2" - (canonical-package (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2))) - ("2.0" - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.0)))) - (define* (guix-derivation source version #:optional (guile-version (effective-version)) #:key (pull-version 0)) @@ -942,9 +956,16 @@ is not supported." (define guile ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2 ;; unconditionally. - (guile-for-build (if (>= pull-version 1) - "2.2" - guile-version))) + (default-guile)) + + (when (and (< pull-version 1) + (not (string=? (package-version guile) guile-version))) + ;; Guix < 0.15.0 has PULL-VERSION = 0, where the host Guile is reused and + ;; can be any version. When that happens and Guile is not current (e.g., + ;; it's Guile 2.0), just bail out. + (raise (condition + (&message + (message "Guix is too old and cannot be upgraded"))))) (mbegin %store-monad (set-guile-for-build guile) diff --git a/guix/serialization.scm b/guix/serialization.scm index 87ad7eeec0..e14b7d1b9f 100644 --- a/guix/serialization.scm +++ b/guix/serialization.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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,7 +59,7 @@ ;; Similar to serialize.cc in Nix. -(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? +(define-condition-type &nar-error &error ; XXX: inherit from &store-error ? nar-error? (file nar-error-file) ; file we were restoring, or #f (port nar-error-port)) ; port from which we read @@ -380,10 +380,19 @@ which case you can use 'identity'." (&nar-error (file f) (port port)))))) (write-string ")" p))) +(define port-conversion-strategy + (fluid->parameter %default-port-conversion-strategy)) + (define (restore-file port file) "Read a file (possibly a directory structure) in Nar format from PORT. Restore it as FILE." - (parameterize ((currently-restored-file file)) + (parameterize ((currently-restored-file file) + + ;; Error out if we can convert file names to the current + ;; locale. (XXX: We'd prefer UTF-8 encoding for file names + ;; regardless of the locale, but that's what Guile gives us + ;; so far.) + (port-conversion-strategy 'error)) (let ((signature (read-string port))) (unless (equal? signature %archive-version-1) (raise diff --git a/guix/ssh.scm b/guix/ssh.scm index 104f4f52d6..2b286a67b2 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix i18n) #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ssh session) @@ -26,8 +27,6 @@ #:use-module (ssh channel) #:use-module (ssh popen) #:use-module (ssh session) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -36,6 +35,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:export (open-ssh-session + remote-inferior remote-daemon-channel connect-to-remote-daemon send-files @@ -94,6 +94,26 @@ 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"))) + (port->inferior pipe))) + +(define (inferior-remote-eval exp session) + "Evaluate EXP in a new inferior running in SESSION, and close the inferior +right away." + (let ((inferior (remote-inferior session))) + (dynamic-wind + (const #t) + (lambda () + (inferior-eval exp inferior)) + (lambda () + ;; Close INFERIOR right away to prevent finalization from happening in + ;; another thread at the wrong time (see + ;; <https://bugs.gnu.org/26976>.) + (close-inferior inferior))))) + (define* (remote-daemon-channel session #:optional (socket-name @@ -120,12 +140,12 @@ Throw an error on failure." (match (select read write except) ((read write except) (select read write except 0)))))) - (setvbuf stdout _IONBF) + (setvbuf stdout 'none) ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. - (setvbuf stdin _IOFBF 65536) - (setvbuf sock _IOFBF 65536) + (setvbuf stdin 'block 65536) + (setvbuf sock 'block 65536) (connect sock AF_UNIX ,socket-name) @@ -160,7 +180,7 @@ Throw an error on failure." (socket-name "/var/guix/daemon-socket/socket")) "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, -an SSH session. Return a <nix-server> object." +an SSH session. Return a <store-connection> object." (open-connection #:port (remote-daemon-channel session socket-name))) @@ -198,7 +218,7 @@ can be written." (consume-input (current-input-port)) (list 'protocol-error (nix-protocol-error-message c)))) (with-store store - (setvbuf (current-input-port) _IONBF) + (setvbuf (current-input-port) 'none) (import-paths store (current-input-port)) '(success)))) (lambda args @@ -249,7 +269,7 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." (write '(exporting)) ;we're ready (force-output) - (setvbuf (current-output-port) _IONBF) + (setvbuf (current-output-port) 'none) (export-paths store files (current-output-port) #:recursive? ,recursive?)))))) @@ -268,16 +288,16 @@ REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES. Return the list of store items actually sent." ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) - (session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) - - (with-store store - (remove (cut valid-path? store <>) - ',files))))) + (session (channel-get-session (store-connection-socket remote))) + (missing (inferior-remote-eval + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',files))) + session)) (count (length missing)) (sizes (map (lambda (item) (path-info-nar-size (query-path-info local item))) @@ -308,24 +328,24 @@ Return the list of store items actually sent." missing) (('protocol-error message) (raise (condition - (&nix-protocol-error (message message) (status 42))))) + (&store-protocol-error (message message) (status 42))))) (('error key args ...) (raise (condition - (&nix-protocol-error + (&store-protocol-error (message (call-with-output-string (lambda (port) (print-exception port #f key args)))) (status 43))))) (_ (raise (condition - (&nix-protocol-error + (&store-protocol-error (message "unknown error while sending files over SSH") (status 44))))))))) (define (remote-store-session remote) "Return the SSH channel beneath REMOTE, a remote store as returned by 'connect-to-remote-daemon', or #f." - (channel-get-session (nix-server-socket remote))) + (channel-get-session (store-connection-socket remote))) (define (remote-store-host remote) "Return the name of the host REMOTE is connected to, where REMOTE is a diff --git a/guix/status.scm b/guix/status.scm index d4fc4ca16e..984f329964 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,8 +27,10 @@ #:select (nar-uri-abbreviation)) #:use-module (guix store) #:use-module (guix derivations) + #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 regex) @@ -49,6 +51,14 @@ build-status-builds-completed build-status-downloads-completed + build? + build + build-derivation + build-system + build-log-file + build-phase + build-completion + download? download download-item @@ -63,7 +73,8 @@ print-build-event/quiet print-build-status - with-status-report)) + with-status-report + with-status-verbosity)) ;;; Commentary: ;;; @@ -83,15 +94,32 @@ ;; Builds and substitutions performed by the daemon. (define-record-type* <build-status> build-status make-build-status build-status? - (building build-status-building ;list of drv + (building build-status-building ;list of <build> (default '())) (downloading build-status-downloading ;list of <download> (default '())) - (builds-completed build-status-builds-completed ;list of drv + (builds-completed build-status-builds-completed ;list of <build> (default '())) - (downloads-completed build-status-downloads-completed ;list of store items + (downloads-completed build-status-downloads-completed ;list of <download> (default '()))) +;; On-going or completed build. +(define-immutable-record-type <build> + (%build derivation id system log-file phase completion) + build? + (derivation build-derivation) ;string (.drv file name) + (id build-id) ;#f | integer + (system build-system) ;string + (log-file build-log-file) ;#f | string + (phase build-phase ;#f | symbol + set-build-phase) + (completion build-completion ;#f | integer (percentage) + set-build-completion)) + +(define* (build derivation system #:key id log-file phase completion) + "Return a new build." + (%build derivation id system log-file phase completion)) + ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. (define-record-type <download> @@ -111,11 +139,77 @@ "Return a new download." (%download item uri size start end transferred)) +(define (matching-build drv) + "Return a predicate that matches builds of DRV." + (lambda (build) + (string=? drv (build-derivation build)))) + (define (matching-download item) "Return a predicate that matches downloads of ITEM." (lambda (download) (string=? item (download-item download)))) +(define %phase-start-rx + ;; Match the "starting phase" message emitted by 'gnu-build-system'. + (make-regexp "^starting phase [`']([^']+)'")) + +(define %percentage-line-rx + ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp + ;; matches them. + (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]")) + +(define %fraction-line-rx + ;; The 'compiled-modules' derivations and Ninja produce reports like + ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]". + ;; This regexp matches these. + (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]")) + +(define (update-build status id line) + "Update STATUS based on LINE, a build output line for ID that might contain +a completion indication." + (define (find-build) + (find (lambda (build) + (and (build-id build) + (= (build-id build) id))) + (build-status-building status))) + + (define (update %) + (let ((build (find-build))) + (build-status + (inherit status) + (building (cons (set-build-completion build %) + (delq build (build-status-building status))))))) + + (cond ((string-any #\nul line) + ;; Don't try to match a regexp here. + status) + ((regexp-exec %percentage-line-rx line) + => + (lambda (match) + (let ((% (string->number (match:substring match 1)))) + (update %)))) + ((regexp-exec %fraction-line-rx line) + => + (lambda (match) + (let ((done (string->number (match:substring match 1))) + (total (string->number (match:substring match 3)))) + (update (* 100. (/ done total)))))) + ((regexp-exec %phase-start-rx line) + => + (lambda (match) + (let ((phase (match:substring match 1)) + (build (find-build))) + (if build + (build-status + (inherit status) + (building + (cons (set-build-phase (set-build-completion build #f) + (string->symbol phase)) + (delq build (build-status-building status))))) + status)))) + (else + status))) + (define* (compute-status event status #:key (current-time current-time) @@ -124,15 +218,29 @@ "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), compute a new status based on STATUS." (match event - (('build-started drv _ ...) - (build-status - (inherit status) - (building (cons drv (build-status-building status))))) + (('build-started drv "-" system log-file . rest) + (let ((build (build drv system + #:id (match rest + ((pid . _) (string->number pid)) + (_ #f)) + #:log-file (if (string-null? log-file) + #f + log-file)))) + (build-status + (inherit status) + (building (cons build (build-status-building status)))))) (((or 'build-succeeded 'build-failed) drv _ ...) - (build-status - (inherit status) - (building (delete drv (build-status-building status))) - (builds-completed (cons drv (build-status-builds-completed status))))) + (let ((build (find (matching-build drv) + (build-status-building status)))) + ;; If BUILD is #f, this may be because DRV corresponds to a + ;; fixed-output derivation that is listed as a download. + (if build + (build-status + (inherit status) + (building (delq build (build-status-building status))) + (builds-completed + (cons build (build-status-builds-completed status)))) + status))) ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because ;; they're not as informative as 'download-started' and @@ -144,10 +252,11 @@ compute a new status based on STATUS." ;; because ITEM is different from DRV's output. (build-status (inherit status) - (building (remove (lambda (drv) - (equal? (false-if-exception - (derivation-path->output-path drv)) - item)) + (building (remove (lambda (build) + (let ((drv (build-derivation build))) + (equal? (false-if-exception + (derivation-path->output-path drv)) + item))) (build-status-building status))) (downloading (cons (download item uri #:size size #:start (current-time time-monotonic)) @@ -202,6 +311,8 @@ compute a new status based on STATUS." (current-time time-monotonic)) #:transferred transferred) downloads))))) + (('build-log (? integer? pid) line) + (update-build status pid line)) (_ status))) @@ -228,22 +339,34 @@ build-log\" traces." (and (current-store-protocol-version) (>= (current-store-protocol-version) #x163))) +(define isatty?* + (mlambdaq (port) + (isatty? port))) + (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) - (lambda (port) - "Display a spinner on PORT." - (match steps - ((first . rest) - (set! steps rest) - (display "\r\x1b[K" port) - (display first port) - (force-output port)))))) + (lambda (phase port) + "Display a spinner on PORT. If PHASE is true, display it as a hint of +the current build phase." + (when (isatty?* port) + (match steps + ((first . rest) + (set! steps rest) + (display "\r\x1b[K" port) + (display first port) + (when phase + (display " " port) + ;; TRANSLATORS: The word "phase" here denotes a "build phase"; + ;; "~a" is a placeholder for the untranslated name of the current + ;; build phase--e.g., 'configure' or 'build'. + (format port (G_ "'~a' phase") phase)) + (force-output port))))))) (define (color-output? port) "Return true if we should write colored output to PORT." (and (not (getenv "INSIDE_EMACS")) (not (getenv "NO_COLOR")) - (isatty? port))) + (isatty?* port))) (define-syntax color-rules (syntax-rules () @@ -311,8 +434,12 @@ on." (G_ "building XDG MIME database...")) ('fonts-dir (G_ "building fonts directory...")) + ('texlive-configuration + (G_ "building TeX Live configuration...")) ('manual-database (G_ "building database for manual pages...")) + ('package-cache ;package cache generated by 'guix pull' + (G_ "building package cache...")) (_ #f))) (define* (print-build-event event old-status status @@ -338,17 +465,47 @@ addition to build events." (cut colorize-string <> 'RED 'BOLD) identity)) + (define (report-build-progress phase %) + (let ((% (min (max % 0) 100))) ;sanitize + (erase-current-line port) + (let* ((prefix (format #f "~3d% ~@['~a' ~]" + (inexact->exact (round %)) + (case phase + ((build) #f) ;not useful to display it + (else phase)))) + (length (string-length prefix))) + (display prefix port) + (display (progress-bar % (- (current-terminal-columns) length)) + port)) + (force-output port))) + (define print-log-line (if print-log? (if colorize? - (lambda (line) + (lambda (id line) (display (colorize-log-line line) port)) - (cut display <> port)) - (lambda (line) - (spin! port)))) + (lambda (id line) + (display line port))) + (lambda (id line) + (match (build-status-building status) + ((build) ;single job + (match (build-completion build) + ((? number? %) + (report-build-progress (build-phase build) %)) + (_ + (spin! (build-phase build) port)))) + (_ + (spin! #f port)))))) + + (define erase-current-line* + (if (isatty?* port) + (lambda (port) + (erase-current-line port) + (force-output port)) + (const #t))) (unless print-log? - (display "\r" port)) ;erase the spinner + (erase-current-line* port)) ;clear the spinner or progress bar (match event (('build-started drv . _) (let ((properties (derivation-properties @@ -383,7 +540,7 @@ addition to build events." (N_ "The following build is still in progress:~%~{ ~a~%~}~%" "The following builds are still in progress:~%~{ ~a~%~}~%" (length ongoing)) - ongoing)))) + (map build-derivation ongoing))))) (('build-failed drv . _) (format port (failure (G_ "build of ~a failed")) drv) (newline port) @@ -449,7 +606,7 @@ addition to build events." ;; through. (display line port) (force-output port)) - (print-log-line line)) + (print-log-line pid line)) (cond ((string-prefix? "substitute: " line) ;; The daemon prefixes early messages coming with 'guix ;; substitute' with "substitute:". These are useful ("updating @@ -462,7 +619,7 @@ addition to build events." (display (info (string-trim-right line)) port) (newline)) (else - (print-log-line line))))) + (print-log-line pid line))))) (_ event))) @@ -559,7 +716,11 @@ The second return value is a thunk to retrieve the current state." (define (process-line line) (cond ((string-prefix? "@ " line) - (match (string-tokenize (string-drop line 2)) + ;; Note: Drop the trailing \n, and use 'string-split' to preserve + ;; spaces (the log file part of 'build-started' events can be the + ;; empty string.) + (match (string-split (string-drop (string-drop-right line 1) 2) + #\space) (("build-log" (= string->number pid) (= string->number len)) (set! %build-output-pid pid) (set! %build-output '()) @@ -636,9 +797,7 @@ The second return value is a thunk to retrieve the current state." ;; The build port actually receives Unicode strings. (set-port-encoding! port "UTF-8") - (cond-expand - ((and guile-2 (not guile-2.2)) #t) - (else (setvbuf port 'line))) + (setvbuf port 'line) (values port (lambda () %state))) (define (call-with-status-report on-event thunk) @@ -651,3 +810,17 @@ The second return value is a thunk to retrieve the current state." "Set up build status reporting to the user using the ON-EVENT procedure; evaluate EXP... in that context." (call-with-status-report on-event (lambda () exp ...))) + +(define (logger-for-level level) + "Return the logging procedure that corresponds to LEVEL." + (cond ((<= level 0) (const #t)) + ((= level 1) print-build-event/quiet) + (else print-build-event))) + +(define (call-with-status-verbosity level thunk) + (call-with-status-report (logger-for-level level) thunk)) + +(define-syntax-rule (with-status-verbosity level exp ...) + "Set up build status reporting to the user at the given LEVEL: 0 means +silent, 1 means quiet, 2 means verbose. Evaluate EXP... in that context." + (call-with-status-verbosity level (lambda () exp ...))) diff --git a/guix/store.scm b/guix/store.scm index 042dfab67f..0a0a7c7c52 100644 --- a/guix/store.scm +++ b/guix/store.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 Jan Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -20,6 +20,7 @@ (define-module (guix store) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix deprecation) #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix monads) @@ -51,14 +52,31 @@ %gc-roots-directory %default-substitute-urls + store-connection? + store-connection-version + store-connection-major-version + store-connection-minor-version + store-connection-socket + + ;; Deprecated forms for 'store-connection'. nix-server? nix-server-version nix-server-major-version nix-server-minor-version nix-server-socket + current-store-protocol-version ;for internal use mcached + &store-error store-error? + &store-connection-error store-connection-error? + store-connection-error-file + store-connection-error-code + &store-protocol-error store-protocol-error? + store-protocol-error-message + store-protocol-error-status + + ;; Deprecated forms for '&store-error' et al. &nix-error nix-error? &nix-connection-error nix-connection-error? nix-connection-error-file @@ -335,59 +353,83 @@ ;; remote-store.cc -(define-record-type* <nix-server> nix-server %make-nix-server - nix-server? - (socket nix-server-socket) - (major nix-server-major-version) - (minor nix-server-minor-version) +(define-record-type* <store-connection> store-connection %make-store-connection + store-connection? + (socket store-connection-socket) + (major store-connection-major-version) + (minor store-connection-minor-version) - (buffer nix-server-output-port) ;output port - (flush nix-server-flush-output) ;thunk + (buffer store-connection-output-port) ;output port + (flush store-connection-flush-output) ;thunk ;; Caches. We keep them per-connection, because store paths build ;; during the session are temporary GC roots kept for the duration of ;; the session. - (ats-cache nix-server-add-to-store-cache) - (atts-cache nix-server-add-text-to-store-cache) - (object-cache nix-server-object-cache + (ats-cache store-connection-add-to-store-cache) + (atts-cache store-connection-add-text-to-store-cache) + (object-cache store-connection-object-cache (default vlist-null))) ;vhash -(set-record-type-printer! <nix-server> +(set-record-type-printer! <store-connection> (lambda (obj port) - (format port "#<build-daemon ~a.~a ~a>" - (nix-server-major-version obj) - (nix-server-minor-version obj) + (format port "#<store-connection ~a.~a ~a>" + (store-connection-major-version obj) + (store-connection-minor-version obj) (number->string (object-address obj) 16)))) -(define-condition-type &nix-error &error - nix-error?) +(define-deprecated/alias nix-server? store-connection?) +(define-deprecated/alias nix-server-major-version + store-connection-major-version) +(define-deprecated/alias nix-server-minor-version + store-connection-minor-version) +(define-deprecated/alias nix-server-socket store-connection-socket) + + +(define-condition-type &store-error &error + store-error?) + +(define-condition-type &store-connection-error &store-error + store-connection-error? + (file store-connection-error-file) + (errno store-connection-error-code)) + +(define-condition-type &store-protocol-error &store-error + store-protocol-error? + (message store-protocol-error-message) + (status store-protocol-error-status)) + +(define-deprecated/alias &nix-error &store-error) +(define-deprecated/alias nix-error? store-error?) +(define-deprecated/alias &nix-connection-error &store-connection-error) +(define-deprecated/alias nix-connection-error? store-connection-error?) +(define-deprecated/alias nix-connection-error-file + store-connection-error-file) +(define-deprecated/alias nix-connection-error-code + store-connection-error-code) +(define-deprecated/alias &nix-protocol-error &store-protocol-error) +(define-deprecated/alias nix-protocol-error? store-protocol-error?) +(define-deprecated/alias nix-protocol-error-message + store-protocol-error-message) +(define-deprecated/alias nix-protocol-error-status + store-protocol-error-status) -(define-condition-type &nix-connection-error &nix-error - nix-connection-error? - (file nix-connection-error-file) - (errno nix-connection-error-code)) - -(define-condition-type &nix-protocol-error &nix-error - nix-protocol-error? - (message nix-protocol-error-message) - (status nix-protocol-error-status)) (define-syntax-rule (system-error-to-connection-error file exp ...) "Catch 'system-error' exceptions and translate them to -'&nix-connection-error'." +'&store-connection-error'." (catch 'system-error (lambda () exp ...) (lambda args (let ((errno (system-error-errno args))) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file file) (errno errno)))))))) (define (open-unix-domain-socket file) "Connect to the Unix-domain socket at FILE and return it. Raise a -'&nix-connection-error' upon error." +'&store-connection-error' upon error." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0))) @@ -403,12 +445,7 @@ (define (open-inet-socket host port) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a -'&nix-connection-error' upon error." - ;; Define 'TCP_NODELAY' on Guile 2.0. The value is the same on all GNU - ;; systems. - (cond-expand (guile-2.2 #t) - (else (define TCP_NODELAY 1))) - +'&store-connection-error' upon error." (let ((sock (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0)))) @@ -440,7 +477,7 @@ ;; Connection failed, so try one of the other addresses. (close s) (if (null? rest) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file host) (errno (system-error-errno args))))) (loop rest)))))))))) @@ -449,7 +486,7 @@ "Connect to the daemon at URI, a string that may be an actual URI or a file name." (define (not-supported) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file uri) (errno ENOTSUP))))) @@ -498,8 +535,8 @@ for this connection will be pinned. Return a server object." ;; One of the 'write-' or 'read-' calls below failed, but this is ;; really a connection error. (raise (condition - (&nix-connection-error (file (or port uri)) - (errno EPROTO)) + (&store-connection-error (file (or port uri)) + (errno EPROTO)) (&message (message "build daemon handshake failed")))))) (let*-values (((port) (or port (connect-to-daemon uri))) @@ -520,13 +557,13 @@ for this connection will be pinned. Return a server object." (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) (write-int (if reserve-space? 1 0) port)) - (let ((conn (%make-nix-server port - (protocol-major v) - (protocol-minor v) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) + (let ((conn (%make-store-connection port + (protocol-major v) + (protocol-minor v) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null))) (let loop ((done? (process-stderr conn))) (or done? (process-stderr conn))) conn))))))))) @@ -541,27 +578,29 @@ already taken place on PORT and that we're just continuing on this established connection. Use with care." (let-values (((output flush) (buffering-output-port port (make-bytevector 8192)))) - (%make-nix-server port - (protocol-major version) - (protocol-minor version) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) - -(define (nix-server-version store) + (%make-store-connection port + (protocol-major version) + (protocol-minor version) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null))) + +(define (store-connection-version store) "Return the protocol version of STORE as an integer." - (protocol-version (nix-server-major-version store) - (nix-server-minor-version store))) + (protocol-version (store-connection-major-version store) + (store-connection-minor-version store))) + +(define-deprecated/alias nix-server-version store-connection-version) (define (write-buffered-output server) "Flush SERVER's output port." - (force-output (nix-server-output-port server)) - ((nix-server-flush-output server))) + (force-output (store-connection-output-port server)) + ((store-connection-flush-output server))) (define (close-connection server) "Close the connection to SERVER." - (close (nix-server-socket server))) + (close (store-connection-socket server))) (define-syntax-rule (with-store store exp ...) "Bind STORE to an open connection to the store and evaluate EXPs; @@ -571,7 +610,7 @@ automatically close the store when the dynamic extent of EXP is left." (const #f) (lambda () (parameterize ((current-store-protocol-version - (nix-server-version store))) + (store-connection-version store))) exp) ...) (lambda () (false-if-exception (close-connection store)))))) @@ -613,7 +652,7 @@ to OUT, using chunks of BUFFER-SIZE bytes." (define %newlines ;; Newline characters triggering a flush of 'current-build-output-port'. - ;; Unlike Guile's _IOLBF, we flush upon #\return so that progress reports + ;; Unlike Guile's 'line, we flush upon #\return so that progress reports ;; that use that trick are correctly displayed. (char-set #\newline #\return)) @@ -627,7 +666,7 @@ Since the build process's output cannot be assumed to be UTF-8, we conservatively consider it to be Latin-1, thereby avoiding possible encoding conversion errors." (define p - (nix-server-socket server)) + (store-connection-socket server)) ;; magic cookies from worker-protocol.hh (define %stderr-next #x6f6c6d67) ; "olmg", build log @@ -671,18 +710,18 @@ encoding conversion errors." (let ((error (read-maybe-utf8-string p)) ;; Currently the daemon fails to send a status code for early ;; errors like DB schema version mismatches, so check for EOF. - (status (if (and (>= (nix-server-minor-version server) 8) + (status (if (and (>= (store-connection-minor-version server) 8) (not (eof-object? (lookahead-u8 p)))) (read-int p) 1))) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message error) (status status)))))) ((= k %stderr-last) ;; The daemon is done (see `stopWork' in `nix-worker.cc'.) #t) (else - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "invalid error code") (status k)))))))) @@ -739,7 +778,7 @@ encoding conversion errors." ;; Must be called after `open-connection'. (define socket - (nix-server-socket server)) + (store-connection-socket server)) (let-syntax ((send (syntax-rules () ((_ (type option) ...) @@ -749,22 +788,22 @@ encoding conversion errors." (write-int (operation-id set-options) socket) (send (boolean keep-failed?) (boolean keep-going?) (boolean fallback?) (integer verbosity)) - (when (< (nix-server-minor-version server) #x61) + (when (< (store-connection-minor-version server) #x61) (let ((max-build-jobs (or max-build-jobs 1)) (max-silent-time (or max-silent-time 3600))) (send (integer max-build-jobs) (integer max-silent-time)))) - (when (>= (nix-server-minor-version server) 2) + (when (>= (store-connection-minor-version server) 2) (send (boolean use-build-hook?))) - (when (>= (nix-server-minor-version server) 4) + (when (>= (store-connection-minor-version server) 4) (send (integer build-verbosity) (integer log-type) (boolean print-build-trace))) - (when (and (>= (nix-server-minor-version server) 6) - (< (nix-server-minor-version server) #x61)) + (when (and (>= (store-connection-minor-version server) 6) + (< (store-connection-minor-version server) #x61)) (let ((build-cores (or build-cores (current-processor-count)))) (send (integer build-cores)))) - (when (>= (nix-server-minor-version server) 10) + (when (>= (store-connection-minor-version server) 10) (send (boolean use-substitutes?))) - (when (>= (nix-server-minor-version server) 12) + (when (>= (store-connection-minor-version server) 12) (let ((pairs `(;; This option is honored by 'guix substitute' et al. ,@(if print-build-trace `(("print-extended-build-trace" @@ -889,8 +928,8 @@ bytevector) as its internal buffer, and a thunk to flush this output port." ((_ (name (type arg) ...) docstring return ...) (lambda (server arg ...) docstring - (let* ((s (nix-server-socket server)) - (buffered (nix-server-output-port server))) + (let* ((s (store-connection-socket server)) + (buffered (store-connection-output-port server))) (record-operation 'name) (write-int (operation-id name) buffered) (write-arg type arg buffered) @@ -912,7 +951,7 @@ bytevector) as its internal buffer, and a thunk to flush this output port." invalid item may exist on disk but still be invalid, for instance because it is the result of an aborted or failed build.) -A '&nix-protocol-error' condition is raised if PATH is not prefixed by the +A '&store-protocol-error' condition is raised if PATH is not prefixed by the store directory (/gnu/store)." boolean) @@ -949,7 +988,7 @@ string). Raise an error if no such path exists." REFERENCES is the list of store paths referred to by the resulting store path." (let* ((args `(,bytes ,name ,references)) - (cache (nix-server-add-text-to-store-cache server))) + (cache (store-connection-add-text-to-store-cache server))) (or (hash-ref cache args) (let ((path (add-text-to-store server name bytes references))) (hash-set! cache args path) @@ -978,7 +1017,7 @@ path." ;; We don't use the 'operation' macro so we can pass SELECT? to ;; 'write-file'. (record-operation 'add-to-store) - (let ((port (nix-server-socket server))) + (let ((port (store-connection-socket server))) (write-int (operation-id add-to-store) port) (write-string basename port) (write-int 1 port) ;obsolete, must be #t @@ -1004,7 +1043,7 @@ where FILE is the entry's absolute file name and STAT is the result of ;; Note: We don't stat FILE-NAME at each call, and thus we assume that ;; the file remains unchanged for the lifetime of SERVER. (let* ((args `(,file-name ,basename ,recursive? ,hash-algo ,select?)) - (cache (nix-server-add-to-store-cache server))) + (cache (store-connection-add-to-store-cache server))) (or (hash-ref cache args) (let ((path (add-to-store server basename recursive? hash-algo file-name @@ -1083,14 +1122,14 @@ an arbitrary directory layout in the store without creating a derivation." ((_ 'directory (names . _) ...) names))) (define cache - (nix-server-add-to-store-cache server)) + (store-connection-add-to-store-cache server)) (or (hash-ref cache tree) (begin ;; We don't use the 'operation' macro so we can use 'write-file-tree' ;; instead of 'write-file'. (record-operation 'add-to-store/tree) - (let ((port (nix-server-socket server))) + (let ((port (store-connection-socket server))) (write-int (operation-id add-to-store) port) (write-string basename port) (write-int 1 port) ;obsolete, must be #t @@ -1122,12 +1161,12 @@ outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Return #t on success." (parameterize ((current-store-protocol-version - (nix-server-version store))) - (if (>= (nix-server-minor-version store) 15) + (store-connection-version store))) + (if (>= (store-connection-minor-version store) 15) (build store things mode) (if (= mode (build-mode normal)) (build/old store things) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "unsupported build mode") (status 1)))))))))) @@ -1187,12 +1226,12 @@ error if there is no such root." (define (references/substitutes store items) "Return the list of list of references of ITEMS; the result has the same length as ITEMS. Query substitute information for any item missing from the -store at once. Raise a '&nix-protocol-error' exception if reference +store at once. Raise a '&store-protocol-error' exception if reference information for one of ITEMS is missing." (let* ((requested items) (local-refs (map (lambda (item) (or (hash-ref %reference-cache item) - (guard (c ((nix-protocol-error? c) #f)) + (guard (c ((store-protocol-error? c) #f)) (references store item)))) items)) (missing (fold-right (lambda (item local-ref result) @@ -1208,7 +1247,7 @@ information for one of ITEMS is missing." '() (substitutable-path-info store missing)))) (when (< (length substs) (length missing)) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "cannot determine \ the list of references") (status 1))))) @@ -1339,9 +1378,9 @@ supported by STORE." ;; derivation builders in general, which appeared in Guix > 0.11.0. ;; Return the empty list if it doesn't. Note that this RPC does not ;; exist in 'nix-daemon'. - (if (or (> (nix-server-major-version store) #x100) - (and (= (nix-server-major-version store) #x100) - (>= (nix-server-minor-version store) #x60))) + (if (or (> (store-connection-major-version store) #x100) + (and (= (store-connection-major-version store) #x100) + (>= (store-connection-minor-version store) #x60))) (builders store) '())))) @@ -1371,14 +1410,14 @@ the list of store paths to delete. IGNORE-LIVENESS? should always be #f. MIN-FREED is the minimum amount of disk space to be freed, in bytes, before the GC can stop. Return the list of store paths delete, and the number of bytes freed." - (let ((s (nix-server-socket server))) + (let ((s (store-connection-socket server))) (write-int (operation-id collect-garbage) s) (write-int action s) (write-store-path-list to-delete s) (write-arg boolean #f s) ; ignore-liveness? (write-long-long min-freed s) (write-int 0 s) ; obsolete - (when (>= (nix-server-minor-version server) 5) + (when (>= (store-connection-minor-version server) 5) ;; Obsolete `use-atime' and `max-atime' parameters. (write-int 0 s) (write-int 0 s)) @@ -1394,8 +1433,8 @@ and the number of bytes freed." ;; To be on the safe side, completely invalidate both caches. ;; Otherwise we could end up returning store paths that are no longer ;; valid. - (hash-clear! (nix-server-add-to-store-cache server)) - (hash-clear! (nix-server-add-text-to-store-cache server))) + (hash-clear! (store-connection-add-to-store-cache server)) + (hash-clear! (store-connection-add-text-to-store-cache server))) (values paths freed)))) @@ -1430,7 +1469,7 @@ collected, and the number of bytes freed." "Import the set of store paths read from PORT into SERVER's store. An error is raised if the set of paths read from PORT is not signed (as per 'export-path #:sign? #t'.) Return the list of store paths imported." - (let ((s (nix-server-socket server))) + (let ((s (store-connection-socket server))) (write-int (operation-id import-paths) s) (let loop ((done? (process-stderr server port))) (or done? (loop (process-stderr server port)))) @@ -1438,7 +1477,7 @@ is raised if the set of paths read from PORT is not signed (as per (define* (export-path server path port #:key (sign? #t)) "Export PATH to PORT. When SIGN? is true, sign it." - (let ((s (nix-server-socket server))) + (let ((s (store-connection-socket server))) (write-int (operation-id export-path) s) (write-store-path path s) (write-arg boolean sign? s) @@ -1507,10 +1546,10 @@ OBJECT is typically a high-level object such as a <package> or an <origin>, and RESULT is typically its derivation." (lambda (store) (values result - (nix-server + (store-connection (inherit store) (object-cache (vhash-consq object (cons result keys) - (nix-server-object-cache store))))))) + (store-connection-object-cache store))))))) (define record-cache-lookup! (if (profiled? "object-cache") @@ -1545,7 +1584,7 @@ and KEYS. KEYS is a list of additional keys to match against, and which are compared with 'equal?'. Return #f on failure and the cached result otherwise." (lambda (store) - (let* ((cache (nix-server-object-cache store)) + (let* ((cache (store-connection-object-cache store)) ;; Escape as soon as we find the result. This avoids traversing ;; the whole vlist chain and significantly reduces the number of @@ -1659,7 +1698,7 @@ where FILE is the entry's absolute file name and STAT is the result of "Monadic version of 'query-path-info' that returns #f when ITEM is not in the store." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; ITEM is not in the store; return #f. (values #f store))) (values (query-path-info store item) store)))) @@ -1817,8 +1856,9 @@ syntactically valid store path." "Return the build log file for DRV, a derivation file name, or #f if it could not be found." (let* ((base (basename drv)) - (log (string-append (dirname %state-directory) ; XXX - "/log/guix/drvs/" + (log (string-append (or (getenv "GUIX_LOG_DIRECTORY") + (string-append %localstatedir "/log/guix")) + "/drvs/" (string-take base 2) "/" (string-drop base 2))) (log.gz (string-append log ".gz")) diff --git a/guix/store/database.scm b/guix/store/database.scm index e6bfbe763e..4791f49865 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -79,6 +79,15 @@ as specified by SQL-SCHEMA." create it and initialize it as a new database." (let ((new? (not (file-exists? file))) (db (sqlite-open file))) + ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED + ;; errors when we have several readers: <https://www.sqlite.org/wal.html>. + (sqlite-exec db "PRAGMA journal_mode=WAL;") + + ;; Install a busy handler such that, when the database is locked, sqlite + ;; retries until 30 seconds have passed, at which point it gives up and + ;; throws SQLITE_BUSY. + (sqlite-exec db "PRAGMA busy_timeout = 30000;") + (dynamic-wind noop (lambda () (when new? diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index a777940f86..8ca16a4cd8 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,8 +109,9 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." (get-temp-link target swap-directory)) (lambda args ;; We get ENOSPC when we can't fit an additional entry in - ;; SWAP-DIRECTORY. - (if (= ENOSPC (system-error-errno args)) + ;; SWAP-DIRECTORY. If it's EMLINK, then TARGET has reached its + ;; maximum number of links. + (if (memv (system-error-errno args) `(,ENOSPC ,EMLINK)) #f (apply throw args))))) @@ -169,4 +170,8 @@ under STORE." ;; more entries in .links, but that's fine: we can ;; just stop. #f) + ((= errno EMLINK) + ;; PATH has reached the maximum number of links, but + ;; that's OK: we just can't deduplicate it more. + #f) (else (apply throw args)))))))))) diff --git a/guix/tests.scm b/guix/tests.scm index f4948148c4..749a4edd7a 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -64,7 +64,7 @@ (define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri))) "Open a connection to the build daemon for tests purposes and return it." - (guard (c ((nix-error? c) + (guard (c ((store-error? c) (format (current-error-port) "warning: build daemon error: ~s~%" c) #f)) @@ -334,18 +334,19 @@ CONTENTS." (define-syntax-rule (dummy-package name* extra-fields ...) "Return a \"dummy\" package called NAME*, with all its compulsory fields initialized with default values, and with EXTRA-FIELDS set as specified." - (package extra-fields ... - (name name*) (version "0") (source #f) - (build-system gnu-build-system) - (synopsis #f) (description #f) - (home-page #f) (license #f))) + (let ((p (package + (name name*) (version "0") (source #f) + (build-system gnu-build-system) + (synopsis #f) (description #f) + (home-page #f) (license #f)))) + (package (inherit p) extra-fields ...))) (define-syntax-rule (dummy-origin extra-fields ...) "Return a \"dummy\" origin, with all its compulsory fields initialized with default values, and with EXTRA-FIELDS set as specified." - (origin extra-fields ... - (method #f) (uri "http://www.example.com") - (sha256 (base32 (make-string 52 #\x))))) + (let ((o (origin (method #f) (uri "http://www.example.com") + (sha256 (base32 (make-string 52 #\x)))))) + (origin (inherit o) extra-fields ...))) ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) diff --git a/guix/ui.scm b/guix/ui.scm index 44336ee8fd..9eab4ba3f7 100644 --- a/guix/ui.scm +++ b/guix/ui.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 © 2013, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> @@ -427,11 +427,6 @@ report them in a user-friendly way." (lambda _ (setlocale LC_ALL "")) (lambda args - (cond-expand - ;; Guile 2.2 already emits a warning, so let's not add a second one. - (guile-2.2 #t) - (else (warning (G_ "failed to install locale: ~a~%") - (strerror (system-error-errno args))))) (display-hint (G_ "Consider installing the @code{glibc-utf8-locales} or @code{glibc-locales} package and defining @code{GUIX_LOCPATH}, along these lines: @@ -459,14 +454,14 @@ See the \"Application Setup\" section in the manual, for more info.\n"))))) ;; notified via an EPIPE later. (sigaction SIGPIPE SIG_IGN) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF)) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line)) (define* (show-version-and-exit #:optional (command (car (command-line)))) "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (format #t "Copyright ~a 2018 ~a" + (format #t "Copyright ~a 2019 ~a" ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ @@ -689,14 +684,14 @@ or remove one of them from the profile.") file (or (port-filename* port) port)) (leave (G_ "corrupt input while restoring archive from ~s~%") (or (port-filename* port) port))))) - ((nix-connection-error? c) + ((store-connection-error? c) (leave (G_ "failed to connect to `~a': ~a~%") - (nix-connection-error-file c) - (strerror (nix-connection-error-code c)))) - ((nix-protocol-error? c) + (store-connection-error-file c) + (strerror (store-connection-error-code c)))) + ((store-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. - (leave (G_ "build failed: ~a~%") - (nix-protocol-error-message c))) + (leave (G_ "~a~%") + (store-protocol-error-message c))) ((derivation-missing-output-error? c) (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") (derivation-missing-output c) diff --git a/guix/upstream.scm b/guix/upstream.scm index 9e1056f7a7..9163478099 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,6 +46,7 @@ upstream-source-urls upstream-source-signature-urls upstream-source-archive-types + upstream-source-input-changes url-prefix-predicate coalesce-sources @@ -56,6 +58,12 @@ upstream-updater-predicate upstream-updater-latest + upstream-input-change? + upstream-input-change-name + upstream-input-change-type + upstream-input-change-action + changed-inputs + %updaters lookup-updater @@ -82,7 +90,73 @@ (version upstream-source-version) ;string (urls upstream-source-urls) ;list of strings (signature-urls upstream-source-signature-urls ;#f | list of strings - (default #f))) + (default #f)) + (input-changes upstream-source-input-changes + (default '()) (thunked))) + +;; Representation of an upstream input change. +(define-record-type* <upstream-input-change> + upstream-input-change make-upstream-input-change + upstream-input-change? + (name upstream-input-change-name) ;string + (type upstream-input-change-type) ;symbol: regular | native | propagated + (action upstream-input-change-action)) ;symbol: add | remove + +(define (changed-inputs package package-sexp) + "Return a list of input changes for PACKAGE based on the newly imported +S-expression PACKAGE-SEXP." + (match package-sexp + ((and expr ('package fields ...)) + (let* ((input->name (match-lambda ((name pkg . out) name))) + (new-regular + (match expr + ((path *** ('inputs + ('quasiquote ((label ('unquote sym)) ...)))) label) + (_ '()))) + (new-native + (match expr + ((path *** ('native-inputs + ('quasiquote ((label ('unquote sym)) ...)))) label) + (_ '()))) + (new-propagated + (match expr + ((path *** ('propagated-inputs + ('quasiquote ((label ('unquote sym)) ...)))) label) + (_ '()))) + (current-regular + (map input->name (package-inputs package))) + (current-native + (map input->name (package-native-inputs package))) + (current-propagated + (map input->name (package-propagated-inputs package)))) + (append-map + (match-lambda + ((action type names) + (map (lambda (name) + (upstream-input-change + (name name) + (type type) + (action action))) + names))) + `((add regular + ,(lset-difference equal? + new-regular current-regular)) + (remove regular + ,(lset-difference equal? + current-regular new-regular)) + (add native + ,(lset-difference equal? + new-native current-native)) + (remove native + ,(lset-difference equal? + current-native new-native)) + (add propagated + ,(lset-difference equal? + new-propagated current-propagated)) + (remove propagated + ,(lset-difference equal? + current-propagated new-propagated)))))) + (_ '()))) (define (url-prefix-predicate prefix) "Return a predicate that returns true when passed a package where one of its @@ -268,12 +342,12 @@ values: the item from LST1 and the item from LST2 that match PRED." (define* (package-update store package updaters #:key (key-download 'interactive)) - "Return the new version and the file name of the new version tarball for -PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a -download policy for missing OpenPGP keys; allowed values: 'always', 'never', -and 'interactive' (default)." + "Return the new version, the file name of the new version tarball, and input +changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date. +KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed +values: 'always', 'never', and 'interactive' (default)." (match (package-latest-release* package updaters) - (($ <upstream-source> _ version urls signature-urls) + (($ <upstream-source> _ version urls signature-urls changes) (let*-values (((name) (package-name package)) ((archive-type) @@ -299,9 +373,9 @@ and 'interactive' (default)." (or signature-urls (circular-list #f))))) (let ((tarball (download-tarball store url signature-url #:key-download key-download))) - (values version tarball)))) + (values version tarball changes)))) (#f - (values #f #f)))) + (values #f #f #f)))) (define (update-package-source package version hash) "Modify the source file that defines PACKAGE to refer to VERSION, |