diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-12-05 17:57:35 +0100 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-12-05 17:57:35 +0100 |
commit | 9d5aa009062a49bd035ae33e37f6562526e7d38c (patch) | |
tree | 4ff2302863a5cf9f3cf604240ea793152156f532 /guix | |
parent | 60bd56c6d8368c23dcd97b26501771c82316fc8c (diff) | |
parent | 2c2fc24b899d3286774f60405888718d98211213 (diff) |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
33 files changed, 926 insertions, 365 deletions
diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index 21d84a179a..1418a71091 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -44,8 +44,8 @@ (define (default-uglify-js) "Return the default package to minify JavaScript source files." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((lisp-mod (resolve-interface '(gnu packages lisp)))) - (module-ref lisp-mod 'uglify-js))) + (let ((js-mod (resolve-interface '(gnu packages javascript)))) + (module-ref js-mod 'uglify-js))) (define* (lower name #:key source inputs native-inputs outputs system diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm new file mode 100644 index 0000000000..b776845377 --- /dev/null +++ b/guix/build-system/qt.scm @@ -0,0 +1,295 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system qt) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system cmake) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (%qt-build-system-modules + qt-build + qt-build-system)) + +;; Commentary: +;; +;; This build system is an extension of the 'cmake-build-system'. It +;; accommodates the needs of Qt and KDE applications by adding a phase run +;; after the 'install' phase: +;; +;; 'qt-wrap' phase: +;; +;; This phase looks for Qt5 plugin paths, QML paths and some XDG paths as well +;; as the corresponding environment variables. If any of these is found in +;; the output or if respective environment variables are set, then all +;; programs in the output's "bin", "sbin", "libexec and "lib/libexec" +;; directories are wrapped in scripts defining the necessary environment +;; variables. +;; +;; Code: + +(define %qt-build-system-modules + ;; Build-side modules imported and used by default. + `((guix build qt-build-system) + ,@%cmake-build-system-modules)) + +(define (default-cmake) + "Return the default CMake package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages cmake)))) + (module-ref module 'cmake-minimal))) + +;; This barely is a copy from (guix build-system cmake), only adjusted to use +;; the variables defined here. +(define* (lower name + #:key source inputs native-inputs outputs system target + (cmake (default-cmake)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + `(#:source #:cmake #:inputs #:native-inputs #:outputs + ,@(if target '() '(#:target)))) + + (bag + (name name) + (system system) + (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@`(("cmake" ,cmake)) + ,@native-inputs + ,@(if target + ;; Use the standard cross inputs of + ;; 'gnu-build-system'. + (standard-cross-packages target 'host) + '()) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (host-inputs inputs) + + ;; The cross-libc is really a target package, but for bootstrapping + ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a + ;; native package, so it would end up using a "native" variant of + ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages + ;; would use a target variant (built with 'gnu-cross-build'.) + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target qt-cross-build qt-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) + + +(define* (qt-build store name inputs + #:key (guile #f) + (outputs '("out")) (configure-flags ''()) + (search-paths '()) + (make-flags ''()) + (out-of-source? #t) + (build-type "RelWithDebInfo") + (tests? #t) + (test-target "test") + (parallel-build? #t) (parallel-tests? #f) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build qt-build-system) + %standard-phases)) + (qt-wrap-excluded-outputs ''()) + (system (%current-system)) + (imported-modules %qt-build-system-modules) + (modules '((guix build cmake-build-system) + (guix build utils)))) + "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE +provides a 'CMakeLists.txt' file as its build system." + (define builder + `(begin + (use-modules ,@modules) + (cmake-build #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases ,phases + #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs + #:configure-flags ,configure-flags + #:make-flags ,make-flags + #:out-of-source? ,out-of-source? + #:build-type ,build-type + #:tests? ,tests? + #:test-target ,test-target + #:parallel-build? ,parallel-build? + #:parallel-tests? ,parallel-tests? + #:validate-runpath? ,validate-runpath? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + + +;;; +;;; Cross-compilation. +;;; + +(define* (qt-cross-build store name + #:key + target native-drvs target-drvs + (guile #f) + (outputs '("out")) + (configure-flags ''()) + (search-paths '()) + (native-search-paths '()) + (make-flags ''()) + (out-of-source? #t) + (build-type "RelWithDebInfo") + (tests? #f) ; nothing can be done + (test-target "test") + (parallel-build? #t) (parallel-tests? #f) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug" + "--enable-deterministic-archives")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build qt-build-system) + %standard-phases)) + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (imported-modules %qt-build-system-modules) + (modules '((guix build cmake-build-system) + (guix build utils)))) + "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and +with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its +build system." + (define builder + `(begin + (use-modules ,@modules) + (let () + (define %build-host-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name path) + `(,name . ,path))) + native-drvs)) + + (define %build-target-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name (? package? pkg) sub ...) + (let ((drv (package-cross-derivation store pkg + target system))) + `(,name . ,(apply derivation->output-path drv sub)))) + ((name path) + `(,name . ,path))) + target-drvs)) + + (cmake-build #:source ,(match (assoc-ref native-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:build ,build + #:target ,target + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:native-search-paths ',(map + search-path-specification->sexp + native-search-paths) + #:phases ,phases + #:configure-flags ,configure-flags + #:make-flags ,make-flags + #:out-of-source? ,out-of-source? + #:build-type ,build-type + #:tests? ,tests? + #:test-target ,test-target + #:parallel-build? ,parallel-build? + #:parallel-tests? ,parallel-tests? + #:validate-runpath? ,validate-runpath? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories)))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs (append native-drvs target-drvs) + #:outputs outputs + #:modules imported-modules + #:guile-for-build guile-for-build)) + +(define qt-build-system + (build-system + (name 'qt) + (description + "The CMake build system augmented with definition of suitable environment +variables for Qt and KDE in program wrappers.") + (lower lower))) diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 49549c1b4b..fae1b47ec5 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Björn Höfling <bjoern.hoefling@bjoernhoefling.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -171,6 +172,12 @@ to the default GNU unpack strategy." #:allow-other-keys) (apply invoke `("ant" ,build-target ,@make-flags))) +(define (regular-jar-file-predicate file stat) + "Predicate returning true if FILE is ending on '.jar' +and STAT indicates it is a regular file." + (and ((file-name-predicate "\\.jar$") file stat) + (eq? 'regular (stat:type stat)))) + (define* (generate-jar-indices #:key outputs #:allow-other-keys) "Generate file \"META-INF/INDEX.LIST\". This file does not use word wraps and is preferred over \"META-INF/MANIFEST.MF\", which does use word wraps, @@ -181,7 +188,10 @@ dependencies of this jar file." (invoke "jar" "-i" jar)) (for-each (match-lambda ((output . directory) - (for-each generate-index (find-files directory "\\.jar$")))) + (for-each generate-index + (find-files + directory + regular-jar-file-predicate)))) outputs) #t) @@ -222,7 +232,8 @@ repack them. This is necessary to ensure that archives are reproducible." (for-each (match-lambda ((output . directory) - (for-each repack-archive (find-files directory "\\.jar$")))) + (for-each repack-archive + (find-files directory regular-jar-file-predicate)))) outputs) #t) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 4be5443083..8a8d74ee1b 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -40,21 +40,6 @@ ;; ;; Code: -;; TODO: Move this to (guix build cargo-utils). Will cause a full rebuild -;; of all rust compilers. - -(define (generate-all-checksums dir-name) - (for-each - (lambda (filename) - (let* ((dir (dirname filename)) - (checksum-file (string-append dir "/.cargo-checksum.json"))) - (when (file-exists? checksum-file) (delete-file checksum-file)) - (display (string-append - "patch-cargo-checksums: generate-checksums for " - dir "\n")) - (generate-checksums dir))) - (find-files dir-name "Cargo.toml$"))) - (define (manifest-targets) "Extract all targets from the Cargo.toml manifest" (let* ((port (open-input-pipe "cargo read-manifest")) diff --git a/guix/build/cargo-utils.scm b/guix/build/cargo-utils.scm index 79e5440378..5ac429a62a 100644 --- a/guix/build/cargo-utils.scm +++ b/guix/build/cargo-utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> +;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,7 +23,8 @@ #:use-module (guix build utils) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) - #:export (generate-checksums)) + #:export (generate-checksums + generate-all-checksums)) ;; Commentary: ;; @@ -66,3 +68,15 @@ the same directory." (display "},\"package\":" port) (write (file-sha256 "/dev/null") port) (display "}" port))))) + +(define (generate-all-checksums dir-name) + (for-each + (lambda (filename) + (let* ((dir (dirname filename)) + (checksum-file (string-append dir "/.cargo-checksum.json"))) + (when (file-exists? checksum-file) (delete-file checksum-file)) + (display (string-append + "patch-cargo-checksums: generate-checksums for " + dir "\n")) + (generate-checksums dir))) + (find-files dir-name "Cargo.toml$"))) diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 06ed57c9d7..3781e148ce 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -39,25 +39,32 @@ ;;; ;;; Code: -(define %default-optimizations - ;; Default optimization options (equivalent to -O2 on Guile 2.2). - (append (if (defined? 'tree-il-default-optimization-options) - (tree-il-default-optimization-options) ;Guile 2.2 - (tree-il-optimizations)) ;Guile 3 - (if (defined? 'cps-default-optimization-options) - (cps-default-optimization-options) ;Guile 2.2 - (cps-optimizations)))) ;Guile 3 - -(define %lightweight-optimizations - ;; Lightweight optimizations (like -O0, but with partial evaluation). - (let loop ((opts %default-optimizations) - (result '())) - (match opts - (() (reverse result)) - ((#:partial-eval? _ rest ...) - (loop rest `(#t #:partial-eval? ,@result))) - ((kw _ rest ...) - (loop rest `(#f ,kw ,@result)))))) +(define optimizations-for-level + (or (and=> (false-if-exception + (resolve-interface '(system base optimize))) + (lambda (iface) + (module-ref iface 'optimizations-for-level))) ;Guile 3.0 + (let () ;Guile 2.2 + (define %default-optimizations + ;; Default optimization options (equivalent to -O2 on Guile 2.2). + (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) + + (define %lightweight-optimizations + ;; Lightweight optimizations (like -O0, but with partial evaluation). + (let loop ((opts %default-optimizations) + (result '())) + (match opts + (() (reverse result)) + ((#:partial-eval? _ rest ...) + (loop rest `(#t #:partial-eval? ,@result))) + ((kw _ rest ...) + (loop rest `(#f ,kw ,@result)))))) + + (lambda (level) + (if (<= level 1) + %lightweight-optimizations + %default-optimizations))))) (define (supported-warning-type? type) "Return true if TYPE, a symbol, denotes a supported warning type." @@ -80,8 +87,8 @@ (define (optimization-options file) "Return the default set of optimizations options for FILE." (if (string-contains file "gnu/packages/") - %lightweight-optimizations ;build faster - '())) + (optimizations-for-level 1) ;build faster + (optimizations-for-level 3))) (define (scm->go file) "Strip the \".scm\" suffix from FILE, and append \".go\"." diff --git a/guix/build/download.scm b/guix/build/download.scm index a4c91550a6..141ef409d6 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -187,10 +187,13 @@ name decoding bug described at DIRECTORY. Those authority certificates are checked when 'peer-certificate-status' is later called." (let ((cred (make-certificate-credentials)) - (files (or (scandir directory - (lambda (file) - (string-suffix? ".pem" file))) - '()))) + (files (match (scandir directory (cut string-suffix? ".pem" <>)) + ((or #f ()) + ;; Some distros provide nothing but bundles (*.crt) under + ;; /etc/ssl/certs, so look for them. + (or (scandir directory (cut string-suffix? ".crt" <>)) + '())) + (pem pem)))) (for-each (lambda (file) (let ((file (string-append directory "/" file))) ;; Protect against dangling symlinks. @@ -198,7 +201,7 @@ DIRECTORY. Those authority certificates are checked when (set-certificate-credentials-x509-trust-file!* cred file x509-certificate-format/pem)))) - (or files '())) + files) cred)) (define (peer-certificate session) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 47a9eda9e6..e2b792d3dc 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2016 David Thompson <davet@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> -;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2018, 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,11 +40,10 @@ ;; ;; Code: -;; Directory suffix where we install ELPA packages. We avoid ".../elpa" as -;; Emacs expects to find the ELPA repository 'archive-contents' file and the -;; archive signature. -(define %legacy-install-suffix "/share/emacs/site-lisp") -(define %install-suffix (string-append %legacy-install-suffix "/guix.d")) +;;; All the packages are installed directly under site-lisp, which means that +;;; having that directory in the EMACSLOADPATH is enough to have them found by +;;; Emacs. +(define %install-dir "/share/emacs/site-lisp") ;; These are the default inclusion/exclusion regexps for the install phase. (define %default-include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) @@ -74,50 +73,23 @@ archive, a directory, or an Emacs Lisp file." #t) (gnu:unpack #:source source))) -(define* (set-emacs-load-path #:key source inputs #:allow-other-keys) - (define (inputs->directories inputs) - "Extract the directory part from INPUTS." - (match inputs - (((names . directories) ...) directories))) - - (define (input-directory->el-directory input-directory) - "Return the correct Emacs Lisp directory in INPUT-DIRECTORY or #f, if there -is no Emacs Lisp directory." - (let ((legacy-elisp-directory (string-append input-directory %legacy-install-suffix)) - (guix-elisp-directory - (string-append - input-directory %install-suffix "/" - (store-directory->elpa-name-version input-directory)))) - (cond - ((file-exists? guix-elisp-directory) guix-elisp-directory) - ((file-exists? legacy-elisp-directory) legacy-elisp-directory) - (else #f)))) - - (define (input-directories->el-directories input-directories) - "Return the list of Emacs Lisp directories in INPUT-DIRECTORIES." - (filter-map input-directory->el-directory input-directories)) - - "Set the EMACSLOADPATH environment variable so that dependencies are found." +(define* (add-source-to-load-path #:key dummy #:allow-other-keys) + "Augment the EMACSLOADPATH environment variable with the source directory." (let* ((source-directory (getcwd)) - (input-elisp-directories (input-directories->el-directories - (inputs->directories inputs))) - (emacs-load-path-value - (string-join - (append input-elisp-directories (list source-directory)) - ":" 'suffix))) + (emacs-load-path-value (string-append (getenv "EMACSLOADPATH") ":" + source-directory))) (setenv "EMACSLOADPATH" emacs-load-path-value) - (format #t "environment variable `EMACSLOADPATH' set to ~a\n" - emacs-load-path-value))) + (format #t "source directory ~s appended to the `EMACSLOADPATH' \ +environment variable\n" source-directory))) (define* (build #:key outputs inputs #:allow-other-keys) "Compile .el files." (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) (out (assoc-ref outputs "out")) - (elpa-name-ver (store-directory->elpa-name-version out)) - (el-dir (string-append out %install-suffix "/" elpa-name-ver))) + (site-lisp (string-append out %install-dir))) (setenv "SHELL" "sh") (parameterize ((%emacs emacs)) - (emacs-byte-compile-directory el-dir)))) + (emacs-byte-compile-directory site-lisp)))) (define* (patch-el-files #:key outputs #:allow-other-keys) "Substitute the absolute \"/bin/\" directory with the right location in the @@ -134,9 +106,7 @@ store in '.el' files." #:binary #t)) (let* ((out (assoc-ref outputs "out")) - (elpa-name-ver (store-directory->elpa-name-version out)) - (el-dir (string-append out %install-suffix "/" elpa-name-ver)) - + (site-lisp (string-append out %install-dir)) ;; (ice-9 regex) uses libc's regexp routines, which cannot deal with ;; strings containing NULs. Filter out such files. TODO: Remove ;; this workaround when <https://bugs.gnu.org/30116> is fixed. @@ -150,7 +120,7 @@ store in '.el' files." (error "patch-el-files: unable to locate " cmd-name)) (string-append "\"" cmd "\""))))) - (with-directory-excursion el-dir + (with-directory-excursion site-lisp ;; Some old '.el' files (e.g., tex-buf.el in AUCTeX) are still ;; ISO-8859-1-encoded. (unless (false-if-exception (substitute-program-names)) @@ -201,15 +171,14 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (not (any (cut match-stripped-file "excluded" <>) exclude))))) (let* ((out (assoc-ref outputs "out")) - (elpa-name-ver (store-directory->elpa-name-version out)) - (target-directory (string-append out %install-suffix "/" elpa-name-ver)) + (site-lisp (string-append out %install-dir)) (files-to-install (find-files source install-file?))) (cond ((not (null? files-to-install)) (for-each (lambda (file) (let* ((stripped-file (string-drop file (string-length source))) - (target-file (string-append target-directory stripped-file))) + (target-file (string-append site-lisp stripped-file))) (format #t "`~a' -> `~a'~%" file target-file) (install-file file (dirname target-file)))) files-to-install) @@ -223,14 +192,12 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (define* (move-doc #:key outputs #:allow-other-keys) "Move info files from the ELPA package directory to the info directory." (let* ((out (assoc-ref outputs "out")) - (elpa-name-ver (store-directory->elpa-name-version out)) - (el-dir (string-append out %install-suffix "/" elpa-name-ver)) - (name-ver (strip-store-file-name out)) + (site-lisp (string-append out %install-dir)) (info-dir (string-append out "/share/info/")) - (info-files (find-files el-dir "\\.info$"))) + (info-files (find-files site-lisp "\\.info$"))) (unless (null? info-files) (mkdir-p info-dir) - (with-directory-excursion el-dir + (with-directory-excursion site-lisp (when (file-exists? "dir") (delete-file "dir")) (for-each (lambda (f) (copy-file f (string-append info-dir "/" (basename f))) @@ -242,11 +209,11 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." "Generate the autoloads file." (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) (out (assoc-ref outputs "out")) + (site-lisp (string-append out %install-dir)) (elpa-name-ver (store-directory->elpa-name-version out)) - (elpa-name (package-name->name+version elpa-name-ver)) - (el-dir (string-append out %install-suffix "/" elpa-name-ver))) + (elpa-name (package-name->name+version elpa-name-ver))) (parameterize ((%emacs emacs)) - (emacs-generate-autoloads elpa-name el-dir)))) + (emacs-generate-autoloads elpa-name site-lisp)))) (define (emacs-package? name) "Check if NAME correspond to the name of an Emacs package." @@ -269,7 +236,7 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (define %standard-phases (modify-phases gnu:%standard-phases (replace 'unpack unpack) - (add-after 'unpack 'set-emacs-load-path set-emacs-load-path) + (add-after 'unpack 'add-source-to-load-path add-source-to-load-path) (delete 'bootstrap) (delete 'configure) ;; Move the build phase after install: the .el files are byte compiled diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm new file mode 100644 index 0000000000..46fcad7848 --- /dev/null +++ b/guix/build/qt-build-system.scm @@ -0,0 +1,109 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build qt-build-system) + #:use-module ((guix build cmake-build-system) #:prefix cmake:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + qt-build)) + +;; Commentary: +;; +;; Builder-side code of the standard Qt build procedure. +;; +;; Code: + +(define (variables-for-wrapping base-directories) + + (define (collect-sub-dirs base-directories subdirectory) + (filter-map + (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (if (directory-exists? directory) directory #f))) + base-directories)) + + (filter + (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) + (map + (lambda (var-spec) + `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) + (list + ;; these shall match the search-path-specification for Qt and KDE + ;; libraries + '("XDG_DATA_DIRS" "/share") + '("XDG_CONFIG_DIRS" "/etc/xdg") + '("QT_PLUGIN_PATH" "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) + +(define* (wrap-all-programs #:key inputs outputs + (qt-wrap-excluded-outputs '()) + #:allow-other-keys) + "Implement phase \"qt-wrap\": look for GSettings schemas and +gtk+-v.0 libraries and create wrappers with suitably set environment variables +if found. + +Wrapping is not applied to outputs whose name is listed in +QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not +to contain any Qt binaries, and where wrapping would gratuitously +add a dependency of that output on Qt." + (define (find-files-to-wrap directory) + (append-map + (lambda (dir) + (if (directory-exists? dir) (find-files dir ".*") (list))) + (list (string-append directory "/bin") + (string-append directory "/sbin") + (string-append directory "/libexec") + (string-append directory "/lib/libexec")))) + + (define input-directories + ;; FIXME: Filter out unwanted inputs, e.g. cmake + (match inputs + (((_ . dir) ...) + dir))) + + (define handle-output + (match-lambda + ((output . directory) + (unless (member output qt-wrap-excluded-outputs) + (let ((bin-list (find-files-to-wrap directory)) + (vars-to-wrap (variables-for-wrapping + (append (list output) + input-directories)))) + (when (not (null? vars-to-wrap)) + (for-each (cut apply wrap-program <> vars-to-wrap) + bin-list))))))) + + (for-each handle-output outputs) + #t) + +(define %standard-phases + (modify-phases cmake:%standard-phases + (add-after 'install 'qt-wrap wrap-all-programs))) + +(define* (qt-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply cmake:cmake-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 48a32674e9..d2486ee86c 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -26,9 +26,9 @@ (if env-val (string-append env-val ":" path) path))) (let ((qml-path (suffix "QML2_IMPORT_PATH" - (string-append out "/qml"))) + (string-append out "/lib/qt5/qml"))) (plugin-path (suffix "QT_PLUGIN_PATH" - (string-append out "/plugins"))) + (string-append out "/lib/qt5/plugins"))) (xdg-data-path (suffix "XDG_DATA_DIRS" (string-append out "/share"))) (xdg-config-path (suffix "XDG_CONFIG_DIRS" diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a5a9c92a42..ce7999b433 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1127,7 +1127,9 @@ exception if it's already taken." (lambda (key . args) (match key ('flock-error - (handler args)) + (apply handler args) + ;; No open port to the lock, so return #f. + #f) ('system-error ;; When using the statically-linked Guile in the initrd, ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore diff --git a/guix/gexp.scm b/guix/gexp.scm index b640c079e4..a96592ac76 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -320,9 +320,16 @@ It is implemented as a macro to capture the current source directory where it appears." (syntax-case s () ((_ file rest ...) + (string? (syntax->datum #'file)) + ;; FILE is a literal, so resolve it relative to the source directory. #'(%local-file file (delay (absolute-file-name file (current-source-directory))) rest ...)) + ((_ file rest ...) + ;; Resolve FILE relative to the current directory. + #'(%local-file file + (delay (absolute-file-name file (getcwd))) + rest ...)) ((_) #'(syntax-error "missing file name")) (id diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 5fe3d85a7f..9cf07c9504 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -52,8 +52,8 @@ hackage-package?)) (define ghc-standard-libraries - ;; List of libraries distributed with ghc (8.4.3). - ;; Contents of ...-ghc-8.4.3/lib/ghc-8.4.3. + ;; List of libraries distributed with ghc (8.6.5). + ;; Contents of ...-ghc-8.6.5/lib/ghc-8.6.5. '("ghc" "cabal" ;; in the output of `ghc-pkg list` Cabal is uppercased, but ;; hackage-name->package-name takes this into account. @@ -70,11 +70,13 @@ "ghc-boot" "ghc-boot-th" "ghc-compact" + "ghc-heap" "ghc-prim" "ghci" "haskeline" "hpc" "integer-gmp" + "libiserv" "mtl" "parsec" "pretty" diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 7f089a5cf3..e258c4197f 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -49,7 +49,7 @@ (define-peg-pattern COLON none ":") ;; A string character is any character that is not a quote, or a quote preceded by a backslash. (define-peg-pattern STRCHR body - (or " " "!" (and (ignore "\\") "\"") + (or " " "!" "\n" (and (ignore "\\") "\"") (and (ignore "\\") "\\") (range #\# #\頋))) (define-peg-pattern operator all (or "=" "!" "<" ">")) @@ -249,10 +249,7 @@ path to the repository." (url-dict (metadata-ref opam-content "url")) (source-url (metadata-ref url-dict "src")) (requirements (metadata-ref opam-content "depends")) - (dependencies (filter - (lambda (name) - (not (member name '("dune" "jbuilder")))) - (dependency-list->names requirements))) + (dependencies (dependency-list->names requirements)) (native-dependencies (depends->native-inputs requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) (native-inputs (dependency-list->inputs @@ -264,8 +261,8 @@ path to the repository." native-dependencies)))) ;; If one of these are required at build time, it means we ;; can use the much nicer dune-build-system. - (let ((use-dune? (or (member "dune" native-dependencies) - (member "jbuilder" native-dependencies)))) + (let ((use-dune? (or (member "dune" (append dependencies native-dependencies)) + (member "jbuilder" (append dependencies native-dependencies))))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) @@ -297,7 +294,10 @@ path to the repository." (synopsis ,(metadata-ref opam-content "synopsis")) (description ,(metadata-ref opam-content "description")) (license #f)) - dependencies))))))) + (filter + (lambda (name) + (not (member name '("dune" "jbuilder")))) + dependencies)))))))) (define (opam-recursive-import package-name) (recursive-import package-name #f diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 791b514485..d528aace9a 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -140,7 +140,9 @@ expression describing it." (synopsis (sxml-value '(entry caption *text*))) (version (or (sxml-value '(entry version @ number *text*)) (sxml-value '(entry version @ date *text*)))) - (license (string->license (sxml-value '(entry license @ type *text*)))) + (license (match ((sxpath '(entry license @ type *text*)) sxml) + ((license) (string->license license)) + ((lst ...) (map string->license lst)))) (home-page (string-append "http://www.ctan.org/pkg/" id)) (ref (texlive-ref component id)) (checkout (download-svn-to-store store ref))) @@ -169,7 +171,9 @@ expression describing it." (sxml->string (or (sxml-value '(entry description)) '()))) #\newline))))) - (license ,license))))) + (license ,(match license + ((lst ...) `(list ,@lst)) + (license license))))))) (define texlive->guix-package (memoize diff --git a/guix/lint.scm b/guix/lint.scm index 03a8e88225..cd2ea571ed 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -292,6 +292,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "intltool" "itstool" "qttools" + "yasm" "nasm" "fasm" "python-coverage" "python2-coverage" "python-cython" "python2-cython" "python-docutils" "python2-docutils" @@ -1121,7 +1122,10 @@ Heritage") ((key . args) (if (eq? key skip-key) '() - (apply throw key args))))))) + (with-networking-fail-safe + (G_ "while connecting to Software Heritage") + '() + (apply throw key args)))))))) ;;; diff --git a/guix/profiles.scm b/guix/profiles.scm index cd3b21e390..f5e5cc33d6 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -92,6 +92,7 @@ manifest-pattern-version manifest-pattern-output + concatenate-manifests manifest-remove manifest-add manifest-lookup @@ -515,6 +516,10 @@ procedure is here for backward-compatibility and will eventually vanish." "Return the packages listed in MANIFEST." (sexp->manifest (read port))) +(define (concatenate-manifests lst) + "Concatenate the manifests listed in LST and return the resulting manifest." + (manifest (append-map manifest-entries lst))) + (define (entry-predicate pattern) "Return a procedure that returns #t when passed a manifest entry that matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index fba0f73826..3318ef0889 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -55,7 +55,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 9ad7379bbe..a853ac6c7d 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -504,7 +504,7 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " --no-grafts do not graft packages")) (display (G_ " - --no-build-hook do not attempt to offload builds via the build hook")) + --no-offload do not attempt to offload builds")) (display (G_ " --max-silent-time=SECONDS mark the build as failed after SECONDS of silence")) @@ -545,7 +545,8 @@ talking to a remote daemon\n"))) #:fallback? (assoc-ref opts 'fallback?) #:use-substitutes? (assoc-ref opts 'substitutes?) #:substitute-urls (assoc-ref opts 'substitute-urls) - #:use-build-hook? (assoc-ref opts 'build-hook?) + #:offload? (and (assoc-ref opts 'offload?) + (not (assoc-ref opts 'keep-failed?))) #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) #:print-build-trace (assoc-ref opts 'print-build-trace?) @@ -610,11 +611,15 @@ talking to a remote daemon\n"))) (alist-cons 'graft? #f (alist-delete 'graft? result eq?)) rest))) - (option '("no-build-hook") #f #f + (option '("no-offload" "no-build-hook") #f #f (lambda (opt name arg result . rest) + (when (string=? name "no-build-hook") + (warning (G_ "'--no-build-hook' is deprecated; \ +use '--no-offload' instead~%"))) + (apply values - (alist-cons 'build-hook? #f - (alist-delete 'build-hook? result)) + (alist-cons 'offload? #f + (alist-delete 'offload? result)) rest))) (option '("max-silent-time") #t #f (lambda (opt name arg result . rest) @@ -659,7 +664,7 @@ talking to a remote daemon\n"))) `((build-mode . ,(build-mode normal)) (graft? . #t) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) @@ -802,7 +807,15 @@ build---packages, gexps, derivations, and so on." (append-map (match-lambda (('argument . (? string? spec)) (cond ((derivation-path? spec) - (list (read-derivation-from-file spec))) + (catch 'system-error + (lambda () + (list (read-derivation-from-file spec))) + (lambda args + ;; Non-existent .drv files can be substituted down + ;; the road, so don't error out. + (if (= ENOENT (system-error-errno args)) + '() + (apply throw args))))) ((store-path? spec) ;; Nothing to do; maybe for --log-file. '()) @@ -934,7 +947,11 @@ needed." '()))) (items (filter-map (match-lambda (('argument . (? store-path? file)) - (and (not (derivation-path? file)) + ;; If FILE is a .drv that's not in + ;; store, keep it so that it can be + ;; substituted. + (and (or (not (derivation-path? file)) + (not (file-exists? file))) file)) (_ #f)) opts)) @@ -965,7 +982,8 @@ needed." (map (compose list derivation-file-name) drv) roots)) ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) + (and (build-derivations store (append drv items) + mode) (for-each show-derivation-outputs drv) (for-each (cut register-root store <> <>) (map (lambda (drv) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index ce70f2f0b3..664cb32b7c 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -158,7 +158,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index f311587ec3..bc0ceabd3f 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -62,6 +62,10 @@ Perform the deployment specified by FILE.\n")) (lambda args (show-help) (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix deploy"))) + (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -80,7 +84,7 @@ Perform the deployment specified by FILE.\n")) (debug . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d78ca0f303..f04363750e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -191,7 +191,7 @@ COMMAND or an interactive shell in that environment.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1384f6b41d..e81b6c25f2 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -60,7 +60,7 @@ ;;; retrieving the build output(s) over SSH upon success. ;;; ;;; This command should not be used directly; instead, it is called on-demand -;;; by the daemon, unless it was started with '--no-build-hook' or a client +;;; by the daemon, unless it was started with '--no-offload' or a client ;;; inhibited build hooks. ;;; ;;; Code: @@ -149,19 +149,6 @@ ignoring it~%") (leave (G_ "failed to load machine file '~a': ~s~%") file args)))))) -(define (host-key->type+key host-key) - "Destructure HOST-KEY, an OpenSSH host key string, and return two values: -its key type as a symbol, and the actual base64-encoded string." - (define (type->symbol type) - (and (string-prefix? "ssh-" type) - (string->symbol (string-drop type 4)))) - - (match (string-tokenize host-key) - ((type key x) - (values (type->symbol type) key)) - ((type key) - (values (type->symbol type) key)))) - (define (private-key-from-file* file) "Like 'private-key-from-file', but raise an error that 'with-error-handling' can interpret meaningfully." @@ -203,21 +190,8 @@ private key from '~a': ~a") (build-machine-compression-level machine)))) (match (connect! session) ('ok - ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about - ;; ed25519 keys and 'get-key-type' returns #f in that case. - (let-values (((server) (get-server-public-key session)) - ((type key) (host-key->type+key - (build-machine-host-key machine)))) - (unless (and (or (not (get-key-type server)) - (eq? (get-key-type server) type)) - (string=? (public-key->string server) key)) - ;; Key mismatch: something's wrong. XXX: It could be that the server - ;; provided its Ed25519 key when we where expecting its RSA key. - (leave (G_ "server at '~a' returned host key '~a' of type '~a' \ -instead of '~a' of type '~a'~%") - (build-machine-name machine) - (public-key->string server) (get-key-type server) - key type))) + ;; Make sure the server's key is what we expect. + (authenticate-server* session (build-machine-host-key machine)) (let ((auth (userauth-public-key! session private))) (unless (eq? 'success auth) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 920d6c01fe..61d18e2609 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -759,7 +759,7 @@ last resort for relocation." (profile-name . "guix-profile") (system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (graft? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) @@ -800,6 +800,10 @@ last resort for relocation." (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\d "derivation") #f #f + (lambda (opt name arg result) + (alist-cons 'derivation-only? #t result))) + (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) @@ -918,6 +922,8 @@ Create a bundle of PACKAGE.\n")) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " + -d, --derivation return the derivation of the pack")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) @@ -959,7 +965,10 @@ Create a bundle of PACKAGE.\n")) (list (transform store package) "out"))) (reverse (filter-map maybe-package-argument opts)))) - (manifest-file (assoc-ref opts 'manifest))) + (manifests (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts))) (define properties (if (assoc-ref opts 'save-provenance?) (lambda (package) @@ -973,11 +982,15 @@ Create a bundle of PACKAGE.\n")) (const '()))) (cond - ((and manifest-file (not (null? packages))) + ((and (not (null? manifests)) (not (null? packages))) (leave (G_ "both a manifest and a package list were given~%"))) - (manifest-file - (let ((user-module (make-user-module '((guix profiles) (gnu))))) - (load* manifest-file user-module))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) (else (manifest (map (match-lambda @@ -1002,6 +1015,7 @@ Create a bundle of PACKAGE.\n")) (assoc-ref opts 'system) #:graft? (assoc-ref opts 'graft?)))) (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (derivation? (assoc-ref opts 'derivation-only?)) (relocatable? (assoc-ref opts 'relocatable?)) (proot? (eq? relocatable? 'proot)) (manifest (let ((manifest (manifest-from-args store opts))) @@ -1070,11 +1084,15 @@ Create a bundle of PACKAGE.\n")) #:archiver archiver))) (mbegin %store-monad - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - (munless dry-run? + (munless derivation? + (show-what-to-build* (list drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?)) + (mwhen derivation? + (return (format #t "~a~%" + (derivation-file-name drv)))) + (munless (or derivation? dry-run?) (built-derivations (list drv)) (mwhen gc-root (register-root* (match (derivation->output-paths drv) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index bcd03a1df9..92c6e34194 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -318,7 +318,7 @@ Alternately, see @command{guix package --search-paths -p ~s}.") (debug . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t))) @@ -832,32 +832,17 @@ processed, #f otherwise." (unless dry-run? (delete-matching-generations store profile pattern))) -(define* (manifest-action store profile file opts - #:key dry-run?) - "Change PROFILE to contain the packages specified in FILE." - (let* ((user-module (make-user-module '((guix profiles) (gnu)))) - (manifest (load* file user-module)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (substitutes? (assoc-ref opts 'substitutes?)) - (allow-collisions? (assoc-ref opts 'allow-collisions?))) - (if dry-run? - (format #t (G_ "would install new manifest from '~a' with ~d entries~%") - file (length (manifest-entries manifest))) - (format #t (G_ "installing new manifest from '~a' with ~d entries~%") - file (length (manifest-entries manifest)))) - (build-and-use-profile store profile manifest - #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?))) +(define (load-manifest file) + "Load the user-profile manifest (Scheme code) from FILE and return it." + (let ((user-module (make-user-module '((guix profiles) (gnu))))) + (load* file user-module))) (define %actions ;; List of actions that may be processed. The car of each pair is the ;; action's symbol in the option list; the cdr is the action's procedure. `((roll-back? . ,roll-back-action) (switch-generation . ,switch-generation-action) - (delete-generations . ,delete-generations-action) - (manifest . ,manifest-action))) + (delete-generations . ,delete-generations-action))) (define (process-actions store opts) "Process any install/remove/upgrade action from OPTS." @@ -881,11 +866,7 @@ processed, #f otherwise." ;; First, acquire a lock on the profile, to ensure only one guix process ;; is modifying it at a time. - (with-file-lock/no-wait (string-append profile ".lock") - (lambda (key . args) - (leave (G_ "profile ~a is locked by another process~%") - profile)) - + (with-profile-lock profile ;; Then, process roll-backs, generation removals, etc. (for-each (match-lambda ((key . arg) @@ -896,7 +877,13 @@ processed, #f otherwise." opts) ;; Then, process normal package removal/installation/upgrade. - (let* ((manifest (profile-manifest profile)) + (let* ((files (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts)) + (manifest (match files + (() (profile-manifest profile)) + (_ (concatenate-manifests (map load-manifest files))))) (step1 (options->removable opts manifest (manifest-transaction))) (step2 (options->installable opts manifest step1)) @@ -904,12 +891,23 @@ processed, #f otherwise." (inherit step2) (install (map transform-entry (manifest-transaction-install step2))))) - (new (manifest-perform-transaction manifest step3))) + (new (manifest-perform-transaction manifest step3)) + (trans (if (null? files) + step3 + (fold manifest-transaction-install-entry + step3 + (manifest-entries manifest))))) (warn-about-old-distro) - (unless (manifest-transaction-null? step3) - (show-manifest-transaction store manifest step3 + (unless (manifest-transaction-null? trans) + ;; When '--manifest' is used, display information about TRANS as if we + ;; were starting from an empty profile. + (show-manifest-transaction store + (if (null? files) + manifest + (make-manifest '())) + trans #:dry-run? dry-run?) (build-and-use-profile store profile new #:allow-collisions? allow-collisions? diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 0ab688ac24..19410ad141 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -36,6 +36,8 @@ #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) #:autoload (guix build utils) (which) + #:use-module ((guix build syscalls) + #:select (with-file-lock/no-wait)) #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) @@ -52,6 +54,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (web uri) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -69,7 +72,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) @@ -182,6 +185,42 @@ Download and deploy the latest version of Guix.\n")) %standard-build-options)) +(define %vcs-web-views + ;; Hard-coded list of host names and corresponding web view URL templates. + ;; TODO: Allow '.guix-channel' files to specify a URL template. + (let ((labhub-url (lambda (repository-url commit) + (string-append + (if (string-suffix? ".git" repository-url) + (string-drop-right repository-url 4) + repository-url) + "/commit/" commit)))) + `(("git.savannah.gnu.org" + ,(lambda (repository-url commit) + (string-append (string-replace-substring repository-url + "/git/" "/cgit/") + "/commit/?id=" commit))) + ("notabug.org" ,labhub-url) + ("framagit.org" ,labhub-url) + ("gitlab.com" ,labhub-url) + ("gitlab.inria.fr" ,labhub-url) + ("github.com" ,labhub-url)))) + +(define* (channel-commit-hyperlink channel + #:optional + (commit (channel-commit channel))) + "Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's +text. The hyperlink links to a web view of COMMIT, when available." + (let* ((url (channel-url channel)) + (uri (string->uri url)) + (host (and uri (uri-host uri)))) + (if host + (match (assoc host %vcs-web-views) + (#f + commit) + ((_ template) + (hyperlink (template url commit) commit))) + commit))) + (define* (display-profile-news profile #:key concise? current-is-newer?) "Display what's up in PROFILE--new packages, and all that. If @@ -245,15 +284,20 @@ purposes." ;; When Texinfo markup is invalid, display it as-is. (const title))))))) -(define (display-news-entry entry language port) - "Display ENTRY, a <channel-news-entry>, in LANGUAGE, a language code, to -PORT." +(define (display-news-entry entry channel language port) + "Display ENTRY, a <channel-news-entry> from CHANNEL, in LANGUAGE, a language +code, to PORT." (define body (channel-news-entry-body entry)) + (define commit + (channel-news-entry-commit entry)) + (display-news-entry-title entry language port) (format port (dim (G_ " commit ~a~%")) - (channel-news-entry-commit entry)) + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel commit) + commit)) (newline port) (let ((body (or (assoc-ref body language) (assoc-ref body (%default-message-language)) @@ -291,7 +335,7 @@ to display." (channel-name channel)) (for-each (if concise? (cut display-news-entry-title <> language port) - (cut display-news-entry <> language port)) + (cut display-news-entry <> channel language port)) entries) (newline port) #t)))))) @@ -526,10 +570,17 @@ way and displaying details about the channel's source code." ('branch branch) ('commit commit) _ ...)) - (format #t (G_ " repository URL: ~a~%") url) - (when branch - (format #t (G_ " branch: ~a~%") branch)) - (format #t (G_ " commit: ~a~%") commit)) + (let ((channel (channel (name 'nameless) + (url url) + (branch branch) + (commit commit)))) + (format #t (G_ " repository URL: ~a~%") url) + (when branch + (format #t (G_ " branch: ~a~%") branch)) + (format #t (G_ " commit: ~a~%") + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel commit) + commit)))) (_ #f))) ;; Show most recently installed packages last. @@ -815,11 +866,12 @@ Use '~/.config/guix/channels.scm' instead.")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install instances profile - #:dry-run? - (assoc-ref opts 'dry-run?) - #:use-substitutes? - (assoc-ref opts 'substitutes?)))))))))))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile + #:dry-run? + (assoc-ref opts 'dry-run?) + #:use-substitutes? + (assoc-ref opts 'substitutes?))))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index dba08edf50..b6034a75d2 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -86,6 +86,8 @@ read-narinfo write-narinfo + %allow-unauthenticated-substitutes? + substitute-urls guix-substitute)) @@ -118,15 +120,21 @@ (string-append %state-directory "/substitute/cache")) (string-append (cache-directory #:ensure? #f) "/substitute"))) +(define (warn-about-missing-authentication) + (warning (G_ "authentication and authorization of substitutes \ +disabled!~%")) + #t) + (define %allow-unauthenticated-substitutes? ;; Whether to allow unchecked substitutes. This is useful for testing ;; purposes, and should be avoided otherwise. - (and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") - (cut string-ci=? <> "yes")) - (begin - (warning (G_ "authentication and authorization of substitutes \ -disabled!~%")) - #t))) + (make-parameter + (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") + (cut string-ci=? <> "yes")) + (lambda (value) + (when value + (warn-about-missing-authentication)) + value))) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered @@ -227,58 +235,6 @@ provide." (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) -(define-record-type <cache-info> - (%make-cache-info url store-directory wants-mass-query?) - cache-info? - (url cache-info-url) - (store-directory cache-info-store-directory) - (wants-mass-query? cache-info-wants-mass-query?)) - -(define (download-cache-info url) - "Download the information for the cache at URL. On success, return a -<cache-info> object and a port on which to send further HTTP requests. On -failure, return #f and #f." - (define uri - (string->uri (string-append url "/nix-cache-info"))) - - (define (read-cache-info port) - (alist->record (fields->alist port) - (cut %make-cache-info url <...>) - '("StoreDir" "WantMassQuery"))) - - (catch #t - (lambda () - (case (uri-scheme uri) - ((file) - (values (call-with-input-file (uri-path uri) - read-cache-info) - #f)) - ((http https) - (let ((port (guix:open-connection-for-uri - uri - #:verify-certificate? #f - #:timeout %fetch-timeout))) - (guard (c ((http-get-error? c) - (warning (G_ "while fetching '~a': ~a (~s)~%") - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - (close-connection port) - (warning (G_ "ignoring substitute server at '~s'~%") url) - (values #f #f))) - (values (read-cache-info (http-fetch uri - #:verify-certificate? #f - #:port port - #:keep-alive? #t)) - port)))))) - (lambda (key . args) - (case key - ((getaddrinfo-error system-error) - ;; Silently ignore the error: probably due to lack of network access. - (values #f #f)) - (else - (apply throw key args)))))) - (define-record-type <narinfo> (%make-narinfo path uri-base uris compressions file-sizes file-hashes @@ -366,22 +322,6 @@ must contain the original contents of a narinfo file." (and=> signature narinfo-signature->canonical-sexp)) str))) -(define* (assert-valid-signature narinfo signature hash - #:optional (acl (current-acl))) - "Bail out if SIGNATURE, a canonical sexp representing the signature of -NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO." - (let ((uri (uri->string (first (narinfo-uris narinfo))))) - (signature-case (signature hash acl) - (valid-signature #t) - (invalid-signature - (leave (G_ "invalid signature for '~a'~%") uri)) - (hash-mismatch - (leave (G_ "hash mismatch for '~a'~%") uri)) - (unauthorized-key - (leave (G_ "'~a' is signed with an unauthorized key~%") uri)) - (corrupt-signature - (leave (G_ "signature on '~a' is corrupt~%") uri))))) - (define* (read-narinfo port #:optional url #:key size) "Read a narinfo from PORT. If URL is true, it must be a string used to @@ -422,7 +362,7 @@ No authentication and authorization checks are performed here!" (define* (valid-narinfo? narinfo #:optional (acl (current-acl)) #:key verbose?) "Return #t if NARINFO's signature is not valid." - (or %allow-unauthenticated-substitutes? + (or (%allow-unauthenticated-substitutes?) (let ((hash (narinfo-sha256 narinfo)) (signature (narinfo-signature narinfo)) (uri (uri->string (first (narinfo-uris narinfo))))) @@ -570,6 +510,9 @@ initial connection on which HTTP requests are sent." (let connect ((port port) (requests requests) (result seed)) + (define batch + (at-most 1000 requests)) + ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) (let ((p (or port (guix:open-connection-for-uri @@ -580,7 +523,7 @@ initial connection on which HTTP requests are sent." (when (file-port? p) (setvbuf p 'block (expt 2 16))) - ;; Send REQUESTS, up to a certain number, in a row. + ;; Send BATCH in a row. ;; XXX: Do our own caching to work around inefficiencies when ;; communicating over TLS: <http://bugs.gnu.org/22966>. (let-values (((buffer get) (open-bytevector-output-port))) @@ -588,16 +531,21 @@ initial connection on which HTTP requests are sent." (set-http-proxy-port?! buffer (http-proxy-port? p)) (for-each (cut write-request <> buffer) - (at-most 1000 requests)) + batch) (put-bytevector p (get)) (force-output p)) ;; Now start processing responses. - (let loop ((requests requests) - (result result)) - (match requests + (let loop ((sent batch) + (processed 0) + (result result)) + (match sent (() - (reverse result)) + (match (drop requests processed) + (() + (reverse result)) + (remainder + (connect port remainder result)))) ((head tail ...) (let* ((resp (read-response p)) (body (response-body-port resp)) @@ -608,9 +556,11 @@ initial connection on which HTTP requests are sent." (match (assq 'connection (response-headers resp)) (('connection 'close) (close-connection p) - (connect #f tail result)) ;try again + (connect #f ;try again + (append tail (drop requests processed)) + result)) (_ - (loop tail result)))))))))) ;keep going + (loop tail (+ 1 processed) result)))))))))) ;keep going (define (read-to-eof port) "Read from PORT until EOF is reached. The data are discarded." @@ -628,6 +578,41 @@ if file doesn't exist, and the narinfo otherwise." #f (apply throw args))))) +(define %unreachable-hosts + ;; Set of names of unreachable hosts. + (make-hash-table)) + +(define* (open-connection-for-uri/maybe uri + #:key + (verify-certificate? #f) + (time %fetch-timeout)) + "Open a connection to URI and return a port to it, or, if connection failed, +print a warning and return #f." + (define host + (uri-host uri)) + + (catch #t + (lambda () + (guix:open-connection-for-uri uri + #:verify-certificate? verify-certificate? + #:timeout time)) + (match-lambda* + (('getaddrinfo-error error) + (unless (hash-ref %unreachable-hosts host) + (hash-set! %unreachable-hosts host #t) ;warn only once + (warning (G_ "~a: host not found: ~a~%") + host (gai-strerror error))) + #f) + (('system-error . args) + (unless (hash-ref %unreachable-hosts host) + (hash-set! %unreachable-hosts host #t) + (warning (G_ "~a: connection failed: ~a~%") host + (strerror + (system-error-errno `(system-error ,@args))))) + #f) + (args + (apply throw args))))) + (define (fetch-narinfos url paths) "Retrieve all the narinfos for PATHS from the cache at URL and return them." (define update-progress! @@ -657,13 +642,18 @@ if file doesn't exist, and the narinfo otherwise." (len (response-content-length response)) (cache (response-cache-control response)) (ttl (and cache (assoc-ref cache 'max-age)))) + (update-progress!) + ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. (if (= code 200) ; hit (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) - (update-progress!) - (cons narinfo result)) + (if (string=? (dirname (narinfo-path narinfo)) + (%store-prefix)) + (begin + (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) + (cons narinfo result)) + result)) (let* ((path (uri-path (request-uri request))) (hash-part (basename (string-drop-right path 8)))) ;drop ".narinfo" @@ -674,26 +664,28 @@ if file doesn't exist, and the narinfo otherwise." (if (= 404 code) ttl %narinfo-transient-error-ttl)) - (update-progress!) result)))) - (define (do-fetch uri port) + (define (do-fetch uri) (case (and=> uri uri-scheme) ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) - (update-progress!) - - ;; Note: Do not check HTTPS server certificates to avoid depending on - ;; the X.509 PKI. We can do it because we authenticate narinfos, - ;; which provides a much stronger guarantee. - (let ((result (http-multiple-get uri - handle-narinfo-response '() - requests - #:verify-certificate? #f - #:port port))) - (close-connection port) - (newline (current-error-port)) - result))) + (match (open-connection-for-uri/maybe uri) + (#f + '()) + (port + (update-progress!) + ;; Note: Do not check HTTPS server certificates to avoid depending + ;; on the X.509 PKI. We can do it because we authenticate + ;; narinfos, which provides a much stronger guarantee. + (let ((result (http-multiple-get uri + handle-narinfo-response '() + requests + #:verify-certificate? #f + #:port port))) + (close-port port) + (newline (current-error-port)) + result))))) ((file #f) (let* ((base (string-append (uri-path uri) "/")) (files (map (compose (cut string-append base <> ".narinfo") @@ -704,17 +696,7 @@ if file doesn't exist, and the narinfo otherwise." (leave (G_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) - (let-values (((cache-info port) - (download-cache-info url))) - (and cache-info - (if (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (do-fetch (string->uri url) port) ;reuse PORT - (begin - (warning (G_ "'~a' uses different store '~a'; ignoring it~%") - url (cache-info-store-directory cache-info)) - (close-connection port) - #f))))) + (do-fetch (string->uri url))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index d3e10b6dc7..5f0dce2093 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1020,7 +1020,7 @@ Some ACTIONS support additional ARGS.\n")) `((system . ,(%current-system)) (target . #f) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 19e635555a..1e800e160f 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -94,7 +94,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) - (build-hook? . #t) + (offload? . #t) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) diff --git a/guix/ssh.scm b/guix/ssh.scm index 5fd3c280e8..291ce20b61 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -37,6 +37,8 @@ #:use-module (ice-9 format) #:use-module (ice-9 binary-ports) #:export (open-ssh-session + authenticate-server* + remote-inferior remote-daemon-channel connect-to-remote-daemon @@ -60,15 +62,56 @@ (define %compression "zlib@openssh.com,zlib") +(define (host-key->type+key host-key) + "Destructure HOST-KEY, an OpenSSH host key string, and return two values: +its key type as a symbol, and the actual base64-encoded string." + (define (type->symbol type) + (and (string-prefix? "ssh-" type) + (string->symbol (string-drop type 4)))) + + (match (string-tokenize host-key) + ((type key x) + (values (type->symbol type) key)) + ((type key) + (values (type->symbol type) key)))) + +(define (authenticate-server* session key) + "Make sure the server for SESSION has the given KEY, where KEY is a string +such as \"ssh-ed25519 AAAAC3Nz… root@example.org\". Raise an exception if the +actual key does not match." + (let-values (((server) (get-server-public-key session)) + ((type key) (host-key->type+key key))) + (unless (and (or (not (get-key-type server)) + (eq? (get-key-type server) type)) + (string=? (public-key->string server) key)) + ;; Key mismatch: something's wrong. XXX: It could be that the server + ;; provided its Ed25519 key when we where expecting its RSA key. XXX: + ;; Guile-SSH 0.10.1 doesn't know about ed25519 keys and 'get-key-type' + ;; returns #f in that case. + (raise (condition + (&message + (message (format #f (G_ "server at '~a' returned host key \ +'~a' of type '~a' instead of '~a' of type '~a'~%") + (session-get session 'host) + (public-key->string server) + (get-key-type server) + key type)))))))) + (define* (open-ssh-session host #:key user port identity + host-key (compression %compression) (timeout 3600)) "Open an SSH session for HOST and return it. IDENTITY specifies the file name of a private key to use for authenticating with the host. When USER, PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' -specifies; otherwise use them. Install TIMEOUT as the maximum time in seconds -after which a read or write operation on a channel of the returned session is -considered as failing. +specifies; otherwise use them. + +When HOST-KEY is true, it must be a string like \"ssh-ed25519 AAAAC3Nz… +root@example.org\"; the server is authenticated and an error is raised if its +host key is different from HOST-KEY. + +Install TIMEOUT as the maximum time in seconds after which a read or write +operation on a channel of the returned session is considered as failing. Throw an error on failure." (let ((session (make-session #:user user @@ -78,6 +121,11 @@ Throw an error on failure." #:timeout 10 ;seconds ;; #:log-verbosity 'protocol + ;; Prevent libssh from reading + ;; ~/.ssh/known_hosts when the caller provides + ;; a HOST-KEY to match against. + #:knownhosts (and host-key "/dev/null") + ;; We need lightweight compression when ;; exchanging full archives. #:compression compression @@ -88,6 +136,21 @@ Throw an error on failure." (match (connect! session) ('ok + (if host-key + ;; Make sure the server's key is what we expect. + (authenticate-server* session host-key) + + ;; Authenticate against ~/.ssh/known_hosts. + (match (authenticate-server session) + ('ok #f) + (reason + (raise (condition + (&message + (message (format #f (G_ "failed to authenticate \ +server at '~a': ~a") + (session-get session 'host) + reason)))))))) + ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! session) ('success diff --git a/guix/store.scm b/guix/store.scm index a276554a52..cf25d347fc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -763,7 +763,8 @@ encoding conversion errors." max-build-jobs timeout max-silent-time - (use-build-hook? #t) + (offload? #t) + (use-build-hook? *unspecified*) ;deprecated (build-verbosity 0) (log-type 0) (print-build-trace #t) @@ -803,6 +804,10 @@ encoding conversion errors." (define socket (store-connection-socket server)) + (unless (unspecified? use-build-hook?) + (warn-about-deprecation #:use-build-hook? #f + #:replacement #:offload?)) + (let-syntax ((send (syntax-rules () ((_ (type option) ...) (begin @@ -816,7 +821,9 @@ encoding conversion errors." (max-silent-time (or max-silent-time 3600))) (send (integer max-build-jobs) (integer max-silent-time)))) (when (>= (store-connection-minor-version server) 2) - (send (boolean use-build-hook?))) + (send (boolean (if (unspecified? use-build-hook?) + offload? + use-build-hook?)))) (when (>= (store-connection-minor-version server) 4) (send (integer build-verbosity) (integer log-type) (boolean print-build-trace))) diff --git a/guix/ui.scm b/guix/ui.scm index eb17d274c8..540671f3dd 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -47,8 +47,8 @@ #:use-module ((guix licenses) #:select (license? license-name license-uri)) #:use-module ((guix build syscalls) - #:select (free-disk-space terminal-columns - terminal-rows)) + #:select (free-disk-space terminal-columns terminal-rows + with-file-lock/no-wait)) #:use-module ((guix build utils) ;; XXX: All we need are the bindings related to ;; '&invoke-error'. However, to work around the bug described @@ -111,12 +111,15 @@ package-specification->name+version+output supports-hyperlinks? + hyperlink + file-hyperlink location->hyperlink relevance package-relevance display-search-results + with-profile-lock string->generations string->duration matching-generations @@ -372,7 +375,7 @@ ARGS is the list of arguments received by the 'throw' handler." (report-error loc (G_ "~a~%") message))) (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) - (('srfi-34 obj) + (((or 'srfi-34 '%exception) obj) (if (message-condition? obj) (report-error (and (error-location? obj) (error-location obj)) @@ -404,7 +407,7 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (warning loc (G_ "~a~%") message))) (('unbound-variable _ ...) (report-unbound-variable-error args)) - (('srfi-34 obj) + (((or 'srfi-34 '%exception) obj) (if (message-condition? obj) (warning (G_ "failed to load '~a': ~a~%") file @@ -813,7 +816,7 @@ similar." (match args (('syntax-error proc message properties form . rest) (report-error (G_ "syntax error: ~a~%") message)) - (('srfi-34 obj) + (((or 'srfi-34 '%exception) obj) (if (message-condition? obj) (report-error (G_ "~a~%") (gettext (condition-message obj) @@ -1246,7 +1249,7 @@ documented at (string-append "\x1b]8;;" uri "\x1b\\" text "\x1b]8;;\x1b\\")) -(define (supports-hyperlinks? port) +(define* (supports-hyperlinks? #:optional (port (current-output-port))) "Return true if PORT is a terminal that supports hyperlink escapes." ;; Note that terminals are supposed to ignore OSC escapes they don't ;; understand (this is the case of xterm as of version 349, for instance.) @@ -1255,6 +1258,13 @@ documented at (and (isatty?* port) (not (getenv "INSIDE_EMACS")))) +(define* (file-hyperlink file #:optional (text file)) + "Return TEXT with escapes for a hyperlink to FILE." + (hyperlink (string-append "file://" (gethostname) + (encode-and-join-uri-path + (string-split file #\/))) + text)) + (define (location->hyperlink location) "Return a string corresponding to LOCATION, with escapes for a hyperlink." (let ((str (location->string location)) @@ -1262,10 +1272,7 @@ documented at (location-file location) (search-path %load-path (location-file location))))) (if file - (hyperlink (string-append "file://" (gethostname) - (encode-and-join-uri-path - (string-split file #\/))) - str) + (file-hyperlink file str) str))) (define* (package->recutils p port #:optional (width (%text-width)) @@ -1608,17 +1615,22 @@ DURATION-RELATION with the current time." (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." (unless (zero? number) - (let ((header (format #f (highlight (G_ "Generation ~a\t~a")) number - (date->string - (time-utc->date - (generation-time profile number)) - ;; TRANSLATORS: This is a format-string for date->string. - ;; Please choose a format that corresponds to the - ;; usual way of presenting dates in your locale. - ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html - ;; for details. - (G_ "~b ~d ~Y ~T")))) - (current (generation-number profile))) + (let* ((file (generation-file-name profile number)) + (link (if (supports-hyperlinks?) + (cut file-hyperlink file <>) + identity)) + (header (format #f (link (highlight (G_ "Generation ~a\t~a"))) + number + (date->string + (time-utc->date + (generation-time profile number)) + ;; TRANSLATORS: This is a format-string for date->string. + ;; Please choose a format that corresponds to the + ;; usual way of presenting dates in your locale. + ;; See https://www.gnu.org/software/guile/manual/html_node/SRFI_002d19-Date-to-string.html + ;; for details. + (G_ "~b ~d ~Y ~T")))) + (current (generation-number profile))) (if (= number current) ;; TRANSLATORS: The word "current" here is an adjective for ;; "Generation", as in "current generation". Use the appropriate @@ -1652,6 +1664,26 @@ DURATION-RELATION with the current time." (display-diff profile gen1 gen2)) +(define (profile-lock-handler profile errno . _) + "Handle failure to acquire PROFILE's lock." + ;; NFS mounts can return ENOLCK. When that happens, there's not much that + ;; can be done, so warn the user and keep going. + (if (= errno ENOLCK) + (warning (G_ "cannot lock profile ~a: ~a~%") + profile (strerror errno)) + (leave (G_ "profile ~a is locked by another process~%") + profile))) + +(define profile-lock-file + (cut string-append <> ".lock")) + +(define-syntax-rule (with-profile-lock profile exp ...) + "Grab PROFILE's lock and evaluate EXP... Call 'leave' if the lock is +already taken." + (with-file-lock/no-wait (profile-lock-file profile) + (cut profile-lock-handler profile <...>) + exp ...)) + (define (display-profile-content profile number) "Display the packages in PROFILE, generation NUMBER, in a human-readable way." diff --git a/guix/utils.scm b/guix/utils.scm index c9236ad165..728039fbf0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -790,13 +790,11 @@ be determined." ;; the absolute file name by looking at %LOAD-PATH; doing this at ;; run time rather than expansion time is necessary to allow files ;; to be moved on the file system. - (cond ((not file-name) - #f) ;raising an error would upset Geiser users - ((string-prefix? "/" file-name) - (dirname file-name)) - (else - #`(absolute-dirname #,file-name)))) - (#f + (if (string-prefix? "/" file-name) + (dirname file-name) + #`(absolute-dirname #,file-name))) + ((or ('filename . #f) #f) + ;; raising an error would upset Geiser users #f)))))) ;; A source location. |