diff options
Diffstat (limited to 'guix')
70 files changed, 2873 insertions, 918 deletions
diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm new file mode 100644 index 0000000000..dbfa626a19 --- /dev/null +++ b/guix/build-system/android-ndk.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Danny Milosavljevic <dannym@scratchpost.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 build-system android-ndk) + #:use-module (guix search-paths) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (android-ndk-build-system)) + +(define %android-ndk-build-system-modules + ;; Build-side modules imported by default. + `((guix build android-ndk-build-system) + (guix build syscalls) + ,@%gnu-build-system-modules)) + +(define* (android-ndk-build store name inputs + #:key + (tests? #t) + (test-target #f) + (phases '(@ (guix build android-ndk-build-system) + %standard-phases)) + (outputs '("out")) + (make-flags ''()) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %android-ndk-build-system-modules) + (modules '((guix build android-ndk-build-system) + (guix build utils)))) + "Build SOURCE using Android NDK, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (android-ndk-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:test-target ,test-target + #:tests? ,tests? + #:phases ,phases + #:make-flags (cons* "-f" + ,(string-append + (derivation->output-path + (car (assoc-ref inputs "android-build"))) + "/share/android/build/core/main.mk") + ,make-flags) + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + + (define private-keywords + '(#:source #:target #:inputs #:native-inputs #:outputs)) + + (and (not target) ;; TODO: support cross-compilation + (bag + (name name) + (system system) + (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system' + ,@(standard-packages))) + (build-inputs `(("android-build" ,(module-ref (resolve-interface '(gnu packages android)) 'android-make-stub)) + ("android-googletest" ,(module-ref (resolve-interface '(gnu packages android)) 'android-googletest)) + ,@native-inputs)) + (outputs outputs) + (build android-ndk-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define android-ndk-build-system + (build-system + (name 'android-ndk) + (description + "Android NDK build system, to build Android NDK packages") + (lower lower))) diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 6bdb7061eb..d20f66e1a9 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -53,7 +53,7 @@ release corresponding to NAME and VERSION." (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.6/bioc/src/contrib/Archive/" + (string-append "https://bioconductor.org/packages/3.7/bioc/src/contrib/Archive/" name "_" version ".tar.gz"))) (define %r-build-system-modules diff --git a/guix/build/android-ndk-build-system.scm b/guix/build/android-ndk-build-system.scm new file mode 100644 index 0000000000..3c8f726d1d --- /dev/null +++ b/guix/build/android-ndk-build-system.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.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 build android-ndk-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + android-ndk-build)) + +;; Commentary: +;; +;; Builder-side code of the Android NDK build system. +;; +;; Code: + +(define* (configure #:key inputs outputs #:allow-other-keys) + (let ((library-directories (filter-map (match-lambda + ((name . path) + (if (eq? 'directory (stat:type (stat path))) + path + #f))) + inputs))) + (setenv "CC" "gcc") + (setenv "CXX" "g++") + (setenv "CPPFLAGS" + (string-join + (map (cut string-append "-I " <> "/include") library-directories) + " ")) + (setenv "LDFLAGS" + (string-append "-L . " + (string-join + (map (lambda (x) + (string-append "-L " x "/lib" " -Wl,-rpath=" x "/lib")) + library-directories) + " "))) + #t)) + +(define* (install #:key inputs outputs (make-flags '()) #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (apply invoke "make" "install" + (string-append "prefix=" out) + make-flags) + #t)) + +(define* (check #:key target inputs outputs (tests? (not target)) (make-flags '()) #:allow-other-keys) + (if tests? + (begin + (apply invoke "make" "check" make-flags) + (when (and (file-exists? "tests") tests?) + (with-directory-excursion "tests" + (apply invoke "make" "check" make-flags)))) + (format #t "test suite not run~%")) + #t) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'install install) + (replace 'check check))) + +(define* (android-ndk-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Android NDK package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 6ce813a001..d081a2b313 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -166,12 +166,26 @@ to the default GNU unpack strategy." "/share/java") source-dir test-dir main-class test-include test-exclude)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) - (setenv "CLASSPATH" (generate-classpath inputs))) + (setenv "CLASSPATH" (generate-classpath inputs)) + #t) (define* (build #:key (make-flags '()) (build-target "jar") #:allow-other-keys) (zero? (apply system* `("ant" ,build-target ,@make-flags)))) +(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/MAINFEST.MF\", which does use word wraps, +by Java when resolving dependencies. So we make sure to create it so that +grafting works - and so that the garbage collector doesn't collect +dependencies of this jar file." + (define (generate-index jar) + (invoke "jar" "-i" jar)) + (every (match-lambda + ((output . directory) + (every generate-index (find-files directory "\\.jar$")))) + outputs)) + (define* (strip-jar-timestamps #:key outputs #:allow-other-keys) "Unpack all jar archives, reset the timestamp of all contained files, and @@ -228,11 +242,14 @@ repack them. This is necessary to ensure that archives are reproducible." (define %standard-phases (modify-phases gnu:%standard-phases (replace 'unpack unpack) + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) (replace 'install install) - (add-after 'install 'strip-jar-timestamps strip-jar-timestamps))) + (add-after 'install 'generate-jar-indices generate-jar-indices) + (add-after 'generate-jar-indices 'strip-jar-timestamps + strip-jar-timestamps))) (define* (ant-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index c5e820a00a..dd6373b33a 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -220,6 +220,7 @@ valid." (define %standard-phases/source (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'check) (delete 'build) @@ -227,6 +228,7 @@ valid." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'install) (replace 'build build) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 139b40321f..f52444f61c 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -172,6 +172,7 @@ SRC-NAME as if it was part of the directory DIR-NAME with name (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm index c82d9fef87..9b1112f2d6 100644 --- a/guix/build/cmake-build-system.scm +++ b/guix/build/cmake-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> @@ -73,7 +73,7 @@ '()) ,@configure-flags))) (format #t "running 'cmake' with arguments ~s~%" args) - (zero? (apply system* "cmake" args))))) + (apply invoke "cmake" args)))) (define* (check #:key (tests? #t) (parallel-tests? #t) (test-target "test") #:allow-other-keys) @@ -86,6 +86,7 @@ ;; Everything is as with the GNU Build System except for the `configure' ;; and 'check' phases. (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'check check) (replace 'configure configure))) diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 1bd8c60fe5..7b6e31107c 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -120,6 +120,28 @@ front." (lambda () (set! path initial-value))))) +(define (call/exit-on-exception thunk) + "Evaluate THUNK and exit right away if an exception is thrown." + (catch #t + thunk + (const #f) + (lambda (key . args) + (false-if-exception + ;; Duplicate stderr to avoid thread-safety issues. + (let* ((port (duplicate-port (current-error-port) "w0")) + (stack (make-stack #t)) + (depth (stack-length stack)) + (frame (and (> depth 1) (stack-ref stack 1)))) + (false-if-exception (display-backtrace stack port)) + (print-exception port frame key args))) + + ;; Don't go any further. + (primitive-exit 1)))) + +(define-syntax-rule (exit-on-exception exp ...) + "Evaluate EXP and exit if an exception is thrown." + (call/exit-on-exception (lambda () exp ...))) + (define* (compile-files source-directory build-directory files #:key (host %host-type) @@ -139,15 +161,18 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (define (build file) (with-mutex progress-lock (report-compilation file total completed)) - (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))))))) + + ;; 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-mutex progress-lock (set! completed (+ 1 completed)))) diff --git a/guix/build/cvs.scm b/guix/build/cvs.scm index 9976e624b3..7111043747 100644 --- a/guix/build/cvs.scm +++ b/guix/build/cvs.scm @@ -55,19 +55,20 @@ Return #t on success, #f otherwise." ;; Use "-z0" because enabling compression leads to hangs during checkout on ;; certain repositories, such as ;; ":pserver:anonymous@cvs.savannah.gnu.org:/sources/gnustandards". - (and (zero? (system* cvs-command "-z0" - "-d" cvs-root-directory - "checkout" - (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision) - "-D" "-r") - revision - module)) - ;; Copy rather than rename in case MODULE and DIRECTORY are on - ;; different devices. - (copy-recursively module directory) + (invoke cvs-command "-z0" + "-d" cvs-root-directory + "checkout" + (if (string-match "^[0-9]{4}-[0-9]{2}-[0-9]{2}$" revision) + "-D" "-r") + revision + module) - (with-directory-excursion directory - (for-each delete-file-recursively (find-cvs-directories))) - #t)) + ;; Copy rather than rename in case MODULE and DIRECTORY are on + ;; different devices. + (copy-recursively module directory) + + (with-directory-excursion directory + (for-each delete-file-recursively (find-cvs-directories))) + #t) ;;; cvs.scm ends here diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm index ed86635708..9a72e3d544 100644 --- a/guix/build/dub-build-system.scm +++ b/guix/build/dub-build-system.scm @@ -121,6 +121,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 094b04750a..47a9eda9e6 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -270,6 +270,7 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (modify-phases gnu:%standard-phases (replace 'unpack unpack) (add-after 'unpack 'set-emacs-load-path set-emacs-load-path) + (delete 'bootstrap) (delete 'configure) ;; Move the build phase after install: the .el files are byte compiled ;; directly in the store. diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 2bd4e39854..fdacd30dd6 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2018 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -60,7 +60,9 @@ (define* (emacs-byte-compile-directory dir) "Byte compile all files in DIR and its sub-directories." - (let ((expr `(byte-recompile-directory (file-name-as-directory ,dir) 0))) + (let ((expr `(progn + (setq byte-compile-debug t) ; for proper exit status + (byte-recompile-directory (file-name-as-directory ,dir) 0 1)))) (emacs-batch-eval expr))) (define-syntax emacs-substitute-sexps diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm index f2a646f6f4..6726595fe1 100644 --- a/guix/build/font-build-system.scm +++ b/guix/build/font-build-system.scm @@ -59,6 +59,7 @@ archive, or a font file." (define %standard-phases (modify-phases gnu:%standard-phases (replace 'unpack unpack) + (delete 'bootstrap) (delete 'configure) (delete 'check) (delete 'build) diff --git a/guix/build/glib-or-gtk-build-system.scm b/guix/build/glib-or-gtk-build-system.scm index b6291e735b..ba680fd1a9 100644 --- a/guix/build/glib-or-gtk-build-system.scm +++ b/guix/build/glib-or-gtk-build-system.scm @@ -1,6 +1,7 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -202,16 +203,16 @@ add a dependency of that output on GLib and GTK+." (define* (compile-glib-schemas #:key outputs #:allow-other-keys) "Implement phase \"glib-or-gtk-compile-schemas\": compile \"glib\" schemas if needed." - (every (match-lambda - ((output . directory) - (let ((schemasdir (string-append directory - "/share/glib-2.0/schemas"))) - (if (and (directory-exists? schemasdir) - (not (file-exists? - (string-append schemasdir "/gschemas.compiled")))) - (zero? (system* "glib-compile-schemas" schemasdir)) - #t)))) - outputs)) + (for-each (match-lambda + ((output . directory) + (let ((schemasdir (string-append directory + "/share/glib-2.0/schemas"))) + (when (and (directory-exists? schemasdir) + (not (file-exists? + (string-append schemasdir "/gschemas.compiled")))) + (invoke "glib-compile-schemas" schemasdir))))) + outputs) + #t) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index 7b43361f99..be5ad78b93 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,10 +27,13 @@ #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:export (%standard-phases %license-file-regexp + dump-file-contents gnu-build)) ;; Commentary: @@ -83,6 +87,9 @@ See https://reproducible-builds.org/specs/source-date-epoch/." (#f ; not cross compiling '()))) + ;; Tell 'ld-wrapper' to disallow non-store libraries. + (setenv "GUIX_LD_WRAPPER_ALLOW_IMPURITIES" "no") + ;; When cross building, $PATH must refer only to native (host) inputs since ;; target inputs are not executable. (set-path-environment-variable "PATH" '("bin" "sbin") @@ -152,12 +159,50 @@ working directory." ;; Preserve timestamps (set to the Epoch) on the copied tree so that ;; things work deterministically. (copy-recursively source "." - #:keep-mtime? #t) - #t) - (and (if (string-suffix? ".zip" source) - (zero? (system* "unzip" source)) - (zero? (system* "tar" "xvf" source))) - (chdir (first-subdirectory "."))))) + #:keep-mtime? #t)) + (begin + (if (string-suffix? ".zip" source) + (invoke "unzip" source) + (invoke "tar" "xvf" source)) + (chdir (first-subdirectory ".")))) + #t) + +(define %bootstrap-scripts + ;; Typical names of Autotools "bootstrap" scripts. + '("bootstrap" "bootstrap.sh" "autogen.sh")) + +(define* (bootstrap #:key (bootstrap-scripts %bootstrap-scripts) + #:allow-other-keys) + "If the code uses Autotools and \"configure\" is missing, run +\"autoreconf\". Otherwise do nothing." + ;; Note: Run that right after 'unpack' so that the generated files are + ;; visible when the 'patch-source-shebangs' phase runs. + (if (not (file-exists? "configure")) + + ;; First try one of the BOOTSTRAP-SCRIPTS. If none exists, and it's + ;; clearly an Autoconf-based project, run 'autoreconf'. Otherwise, do + ;; nothing (perhaps the user removed or overrode the 'configure' phase.) + (let ((script (find file-exists? bootstrap-scripts))) + ;; GNU packages often invoke the 'git-version-gen' script from + ;; 'configure.ac' so make sure it has a valid shebang. + (false-if-file-not-found + (patch-shebang "build-aux/git-version-gen")) + + (if script + (let ((script (string-append "./" script))) + (format #t "running '~a'~%" script) + (if (executable-file? script) + (begin + (patch-shebang script) + (invoke script)) + (invoke "sh" script))) + (if (or (file-exists? "configure.ac") + (file-exists? "configure.in")) + (invoke "autoreconf" "-vif") + (format #t "no 'configure.ac' or anything like that, \ +doing nothing~%")))) + (format #t "GNU build system bootstrapping not needed~%")) + #t) ;; See <http://bugs.gnu.org/17840>. (define* (patch-usr-bin-file #:key native-inputs inputs @@ -184,7 +229,8 @@ $CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's (lambda (file stat) ;; Filter out symlinks. (eq? 'regular (stat:type stat))) - #:stat lstat))) + #:stat lstat)) + #t) (define (patch-generated-file-shebangs . rest) "Patch shebangs in generated files, including `SHELL' variables in @@ -199,7 +245,9 @@ makefiles." #:stat lstat)) ;; Patch `SHELL' in generated makefiles. - (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$"))) + (for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")) + + #t) (define* (configure #:key build target native-inputs inputs outputs (configure-flags '()) out-of-source? @@ -279,33 +327,61 @@ makefiles." ;; Call `configure' with a relative path. Otherwise, GCC's build system ;; (for instance) records absolute source file names, which typically ;; contain the hash part of the `.drv' file, leading to a reference leak. - (zero? (apply system* bash - (string-append srcdir "/configure") - flags)))) + (apply invoke bash + (string-append srcdir "/configure") + flags))) (define* (build #:key (make-flags '()) (parallel-build? #t) #:allow-other-keys) - (zero? (apply system* "make" - `(,@(if parallel-build? - `("-j" ,(number->string (parallel-job-count))) - '()) - ,@make-flags)))) + (apply invoke "make" + `(,@(if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) + +(define* (dump-file-contents directory file-regexp + #:optional (port (current-error-port))) + "Dump to PORT the contents of files in DIRECTORY that match FILE-REGEXP." + (define (dump file) + (let ((prefix (string-append "\n--- " file " "))) + (display (if (< (string-length prefix) 78) + (string-pad-right prefix 78 #\-) + prefix) + port) + (display "\n\n" port) + (call-with-input-file file + (lambda (log) + (dump-port log port))) + (display "\n" port))) + + (for-each dump (find-files directory file-regexp))) + +(define %test-suite-log-regexp + ;; Name of test suite log files as commonly found in GNU-based build systems + ;; and CMake. + "^(test-?suite\\.log|LastTestFailed\\.log)$") (define* (check #:key target (make-flags '()) (tests? (not target)) (test-target "check") (parallel-tests? #t) + (test-suite-log-regexp %test-suite-log-regexp) #:allow-other-keys) (if tests? - (zero? (apply system* "make" test-target - `(,@(if parallel-tests? - `("-j" ,(number->string (parallel-job-count))) - '()) - ,@make-flags))) - (begin - (format #t "test suite not run~%") - #t))) + (guard (c ((invoke-error? c) + ;; Dump the test suite log to facilitate debugging. + (display "\nTest suite failed, dumping logs.\n" + (current-error-port)) + (dump-file-contents "." test-suite-log-regexp) + (raise c))) + (apply invoke "make" test-target + `(,@(if parallel-tests? + `("-j" ,(number->string (parallel-job-count))) + '()) + ,@make-flags))) + (format #t "test suite not run~%")) + #t) (define* (install #:key (make-flags '()) #:allow-other-keys) - (zero? (apply system* "make" "install" make-flags))) + (apply invoke "make" "install" make-flags)) (define* (patch-shebangs #:key inputs outputs (patch-shebangs? #t) #:allow-other-keys) @@ -371,10 +447,8 @@ makefiles." (let ((debug (debug-file file))) (mkdir-p (dirname debug)) (copy-file file debug) - (and (zero? (system* strip-command "--only-keep-debug" debug)) - (begin - (chmod debug #o400) - #t)))) + (invoke strip-command "--only-keep-debug" debug) + (chmod debug #o400))) (define (add-debug-link file) ;; Add a debug link in FILE (info "(binutils) strip"). @@ -384,10 +458,10 @@ makefiles." ;; `bfd_fill_in_gnu_debuglink_section' function.) No reference to ;; DEBUG-OUTPUT is kept because bfd keeps only the basename of the debug ;; file. - (zero? (system* objcopy-command "--enable-deterministic-archives" - (string-append "--add-gnu-debuglink=" - (debug-file file)) - file))) + (invoke objcopy-command "--enable-deterministic-archives" + (string-append "--add-gnu-debuglink=" + (debug-file file)) + file)) (define (strip-dir dir) (format #t "stripping binaries in ~s with ~s and flags ~s~%" @@ -397,17 +471,29 @@ makefiles." debug-output objcopy-command)) (for-each (lambda (file) - (and (or (elf-file? file) (ar-file? file)) - (or (not debug-output) - (make-debug-file file)) - - ;; Ensure the file is writable. - (begin (make-file-writable file) #t) - - (zero? (apply system* strip-command - (append strip-flags (list file)))) - (or (not debug-output) - (add-debug-link file)))) + (when (or (elf-file? file) (ar-file? file)) + ;; If an error occurs while processing a file, issue a + ;; warning and continue to the next file. + (guard (c ((invoke-error? c) + (format (current-error-port) + "warning: ~a: program ~s exited\ +~@[ with non-zero exit status ~a~]\ +~@[ terminated by signal ~a~]~%" + file + (invoke-error-program c) + (invoke-error-exit-status c) + (invoke-error-term-signal c)))) + (when debug-output + (make-debug-file file)) + + ;; Ensure the file is writable. + (make-file-writable file) + + (apply invoke strip-command + (append strip-flags (list file))) + + (when debug-output + (add-debug-link file))))) (find-files dir (lambda (file stat) ;; Ignore symlinks such as: @@ -415,15 +501,17 @@ makefiles." (eq? 'regular (stat:type stat))) #:stat lstat))) - (or (not strip-binaries?) - (every strip-dir - (append-map (match-lambda - ((_ . dir) - (filter-map (lambda (d) - (let ((sub (string-append dir "/" d))) - (and (directory-exists? sub) sub))) - strip-directories))) - outputs)))) + (when strip-binaries? + (for-each + strip-dir + (append-map (match-lambda + ((_ . dir) + (filter-map (lambda (d) + (let ((sub (string-append dir "/" d))) + (and (directory-exists? sub) sub))) + strip-directories))) + outputs))) + #t) (define* (validate-runpath #:key (validate-runpath? #t) @@ -466,10 +554,11 @@ phase after stripping." (filter-map (sub-directory output) elf-directories))) outputs))) - (every* validate dirs)) - (begin - (format (current-error-port) "skipping RUNPATH validation~%") - #t))) + (unless (every* validate dirs) + (error "RUNPATH validation failed"))) + (format (current-error-port) "skipping RUNPATH validation~%")) + + #t) (define* (validate-documentation-location #:key outputs #:allow-other-keys) @@ -549,47 +638,45 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (apply throw args)))))) (define (maybe-compress-directory directory regexp) - (or (not (directory-exists? directory)) - (match (find-files directory regexp) - (() ;nothing to compress - #t) - ((files ...) ;one or more files - (format #t - "compressing documentation in '~a' with ~s and flags ~s~%" - directory documentation-compressor - documentation-compressor-flags) - (call-with-values - (lambda () - (partition symbolic-link? files)) - (lambda (symlinks regular-files) - ;; Compress the non-symlink files, and adjust symlinks to refer - ;; to the compressed files. Leave files that have hard links - ;; unchanged ('gzip' would refuse to compress them anyway.) - ;; Also, do not retarget symbolic links pointing to other - ;; symbolic links, since these are not compressed. - (and (every retarget-symlink - (filter (lambda (symlink) - (and (not (points-to-symlink? symlink)) - (string-match regexp symlink))) - symlinks)) - (zero? - (apply system* documentation-compressor - (append documentation-compressor-flags - (remove has-links? regular-files))))))))))) + (when (directory-exists? directory) + (match (find-files directory regexp) + (() ;nothing to compress + #t) + ((files ...) ;one or more files + (format #t + "compressing documentation in '~a' with ~s and flags ~s~%" + directory documentation-compressor + documentation-compressor-flags) + (call-with-values + (lambda () + (partition symbolic-link? files)) + (lambda (symlinks regular-files) + ;; Compress the non-symlink files, and adjust symlinks to refer + ;; to the compressed files. Leave files that have hard links + ;; unchanged ('gzip' would refuse to compress them anyway.) + ;; Also, do not retarget symbolic links pointing to other + ;; symbolic links, since these are not compressed. + (for-each retarget-symlink + (filter (lambda (symlink) + (and (not (points-to-symlink? symlink)) + (string-match regexp symlink))) + symlinks)) + (apply invoke documentation-compressor + (append documentation-compressor-flags + (remove has-links? regular-files))))))))) (define (maybe-compress output) - (and (maybe-compress-directory (string-append output "/share/man") - "\\.[0-9]+$") - (maybe-compress-directory (string-append output "/share/info") - "\\.info(-[0-9]+)?$"))) + (maybe-compress-directory (string-append output "/share/man") + "\\.[0-9]+$") + (maybe-compress-directory (string-append output "/share/info") + "\\.info(-[0-9]+)?$")) (if compress-documentation? (match outputs (((names . directories) ...) - (every maybe-compress directories))) - (begin - (format #t "not compressing documentation~%") - #t))) + (for-each maybe-compress directories))) + (format #t "not compressing documentation~%")) + #t) (define* (delete-info-dir-file #:key outputs #:allow-other-keys) "Delete any 'share/info/dir' file from OUTPUTS." @@ -672,6 +759,7 @@ which cannot be found~%" (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack + bootstrap patch-usr-bin-file patch-source-shebangs configure patch-generated-file-shebangs build check install @@ -704,17 +792,26 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." ;; The trick is to #:allow-other-keys everywhere, so that each procedure in ;; PHASES can pick the keyword arguments it's interested in. - (every (match-lambda - ((name . proc) - (let ((start (current-time time-monotonic))) - (format #t "starting phase `~a'~%" name) - (let ((result (apply proc args)) - (end (current-time time-monotonic))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" - name result - (elapsed-time end start)) - - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases)) + (for-each (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (format #t "starting phase `~a'~%" name) + (let ((result (apply proc args)) + (end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name result + (elapsed-time end start)) + + ;; Issue a warning unless the result is #t. + (unless (eqv? result #t) + (format (current-error-port) "\ +## WARNING: phase `~a' returned `~s'. Return values other than #t +## are deprecated. Please migrate this package so that its phase +## procedures report errors by raising an exception, and otherwise +## always return #t.~%" + name result)) + + ;; Dump the environment variables as a shell script, for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables") + result)))) + phases)) diff --git a/guix/build/gnu-dist.scm b/guix/build/gnu-dist.scm index ad69c6cf16..bf1c63cb85 100644 --- a/guix/build/gnu-dist.scm +++ b/guix/build/gnu-dist.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,24 +42,22 @@ (begin (format #t "bootstrapping with `~a'...~%" file) - (zero? - (system* (string-append "./" file)))) + (invoke (string-append "./" file))) (try-files files ... (else fallback ...))))))) (try-files "bootstrap" "bootstrap.sh" "autogen" "autogen.sh" (else (format #t "bootstrapping with `autoreconf'...~%") - (zero? (system* "autoreconf" "-vfi")))))) + (invoke "autoreconf" "-vfi"))))) (define* (build #:key build-before-dist? make-flags (dist-target "distcheck") #:allow-other-keys #:rest args) - (and (or (not build-before-dist?) - (let ((build (assq-ref %standard-phases 'build))) - (apply build args))) - (begin - (format #t "building target `~a'~%" dist-target) - (zero? (apply system* "make" dist-target make-flags))))) + (when build-before-dist? + (let ((build (assq-ref %standard-phases 'build))) + (apply build args))) + (format #t "building target `~a'~%" dist-target) + (apply invoke "make" dist-target make-flags)) (define* (install-dist #:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 3114067aa9..7c833a616f 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -261,6 +261,7 @@ files in OUTPUTS." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'patch-generated-file-shebangs) (replace 'unpack unpack) diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm index fed529b193..bb019967e5 100644 --- a/guix/build/gremlin.scm +++ b/guix/build/gremlin.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,7 +35,7 @@ elf-dynamic-info elf-dynamic-info? - elf-dynamic-info-sopath + elf-dynamic-info-soname elf-dynamic-info-needed elf-dynamic-info-rpath elf-dynamic-info-runpath diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 3afc37e16d..268d59c1be 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -266,6 +266,7 @@ given Haskell package." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (add-before 'configure 'setup-compiler setup-compiler) (add-before 'install 'haddock haddock) (add-after 'install 'register register) diff --git a/guix/build/hg.scm b/guix/build/hg.scm index ae4574de57..ea51eb670b 100644 --- a/guix/build/hg.scm +++ b/guix/build/hg.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,19 +34,20 @@ "Fetch CHANGESET from URL into DIRECTORY. CHANGESET must be a valid Mercurial changeset identifier. Return #t on success, #f otherwise." - (and (zero? (system* hg-command - "clone" url - "--rev" changeset - ;; Disable TLS certificate verification. The hash of - ;; the checkout is known in advance anyway. - "--insecure" - directory)) - (with-directory-excursion directory - (begin - ;; The contents of '.hg' vary as a function of the current - ;; status of the Mercurial repo. Since we want a fixed - ;; output, this directory needs to be taken out. - (delete-file-recursively ".hg") - #t)))) + (invoke hg-command + "clone" url + "--rev" changeset + ;; Disable TLS certificate verification. The hash of + ;; the checkout is known in advance anyway. + "--insecure" + directory) + + ;; The contents of '.hg' vary as a function of the current + ;; status of the Mercurial repo. Since we want a fixed + ;; output, this directory needs to be taken out. + (with-directory-excursion directory + (delete-file-recursively ".hg")) + + #t) ;;; hg.scm ends here diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm index 3580deda07..563def88e9 100644 --- a/guix/build/minify-build-system.scm +++ b/guix/build/minify-build-system.scm @@ -60,6 +60,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (replace 'build build) (delete 'check) diff --git a/guix/build/ocaml-build-system.scm b/guix/build/ocaml-build-system.scm index f77251ca09..d10431d8ef 100644 --- a/guix/build/ocaml-build-system.scm +++ b/guix/build/ocaml-build-system.scm @@ -103,6 +103,7 @@ ;; Everything is as with the GNU Build System except for the `configure' ;; , `build', `check' and `install' phases. (modify-phases gnu:%standard-phases + (delete 'bootstrap) (add-before 'configure 'ocaml-findlib-environment ocaml-findlib-environment) (add-before 'install 'prepare-install prepare-install) diff --git a/guix/build/perl-build-system.scm b/guix/build/perl-build-system.scm index b2024e4406..c5f5baa3a9 100644 --- a/guix/build/perl-build-system.scm +++ b/guix/build/perl-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,7 +50,7 @@ "INSTALLDIRS=site" "NO_PERLLOCAL=1" ,@make-maker-flags)) (else (error "no Build.PL or Makefile.PL found"))))) (format #t "running `perl' with arguments ~s~%" args) - (zero? (apply system* "perl" args)))) + (apply invoke "perl" args))) (define-syntax-rule (define-w/gnu-fallback* (name args ...) body ...) (define* (name args ... #:rest rest) @@ -58,24 +59,24 @@ (apply (assoc-ref gnu:%standard-phases 'name) rest)))) (define-w/gnu-fallback* (build) - (zero? (system* "./Build"))) + (invoke "./Build")) (define-w/gnu-fallback* (check #:key target (tests? (not target)) (test-flags '()) #:allow-other-keys) (if tests? - (zero? (apply system* "./Build" "test" test-flags)) - (begin - (format #t "test suite not run~%") - #t))) + (apply invoke "./Build" "test" test-flags) + (format #t "test suite not run~%")) + #t) (define-w/gnu-fallback* (install) - (zero? (system* "./Build" "install"))) + (invoke "./Build" "install")) (define %standard-phases ;; Everything is as with the GNU Build System except for the `configure', ;; `build', `check', and `install' phases. (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'install install) (replace 'check check) (replace 'build build) diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index b4160fba1b..819688a913 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:re-export (symlink-relative) ;for convenience #:export (ensure-writable-directory build-profile)) @@ -129,12 +130,15 @@ instead make DIRECTORY a \"real\" directory containing symlinks." (apply throw args)))))) (define* (build-profile output inputs - #:key manifest search-paths) - "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an -sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for --all the variables listed in SEARCH-PATHS." + #:key manifest search-paths + (symlink symlink)) + "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to +create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create +OUTPUT/etc/profile with Bash definitions for -all the variables listed in +SEARCH-PATHS." ;; Make the symlinks. (union-build output inputs + #:symlink symlink #:log-port (%make-void-port "w")) ;; Store meta-data. diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index dd07986b94..376ea81f1a 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -1,9 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,14 +121,15 @@ (format #t "running \"python setup.py\" with command ~s and parameters ~s~%" command params) (if use-setuptools? - (zero? (apply system* "python" "-c" setuptools-shim - command params)) - (zero? (apply system* "python" "./setup.py" command params)))) + (apply invoke "python" "-c" setuptools-shim + command params) + (apply invoke "python" "./setup.py" command params))) (error "no setup.py found"))) (define* (build #:key use-setuptools? #:allow-other-keys) "Build a given Python package." - (call-setuppy "build" '() use-setuptools?)) + (call-setuppy "build" '() use-setuptools?) + #t) (define* (check #:key tests? test-target use-setuptools? #:allow-other-keys) "Run the test suite of a given Python package." @@ -137,15 +139,12 @@ ;; (given with `package_dir`). This will by copied to the output, too, ;; so we need to remove. (let ((before (find-files "build" "\\.egg-info$" #:directories? #t))) - (if (call-setuppy test-target '() use-setuptools?) - (let* ((after (find-files "build" "\\.egg-info$" #:directories? #t)) - (inter (lset-difference eqv? after before))) - (for-each delete-file-recursively inter) - #t) - #f)) - (begin - (format #t "test suite not run~%") - #t))) + (call-setuppy test-target '() use-setuptools?) + (let* ((after (find-files "build" "\\.egg-info$" #:directories? #t)) + (inter (lset-difference string=? after before))) + (for-each delete-file-recursively inter))) + (format #t "test suite not run~%")) + #t) (define (get-python-version python) (let* ((version (last (string-split python #\-))) @@ -182,7 +181,8 @@ when running checks after installing the package." "--root=/") '()) configure-flags))) - (call-setuppy "install" params use-setuptools?))) + (call-setuppy "install" params use-setuptools?) + #t)) (define* (wrap #:key inputs outputs #:allow-other-keys) (define (list-of-files dir) @@ -211,7 +211,8 @@ when running checks after installing the package." (let ((files (list-of-files dir))) (for-each (cut wrap-program <> var) files))) - bindirs))) + bindirs) + #t)) (define* (rename-pth-file #:key name inputs outputs #:allow-other-keys) "Rename easy-install.pth to NAME.pth to avoid conflicts between packages @@ -243,10 +244,21 @@ installed with setuptools." #t)) #t)) +(define* (enable-bytecode-determinism #:rest _) + "Improve determinism of pyc files." + ;; Set DETERMINISTIC_BUILD to override the embedded mtime in pyc files. + (setenv "DETERMINISTIC_BUILD" "1") + ;; Use deterministic hashes for strings, bytes, and datetime objects. + (setenv "PYTHONHASHSEED" "0") + #t) + (define %standard-phases ;; 'configure' phase is not needed. (modify-phases gnu:%standard-phases (add-after 'unpack 'ensure-no-mtimes-pre-1980 ensure-no-mtimes-pre-1980) + (add-after 'ensure-no-mtimes-pre-1980 'enable-bytecode-determinism + enable-bytecode-determinism) + (delete 'bootstrap) (delete 'configure) (replace 'install install) (replace 'check check) diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 24aa73d4f2..4d8ac5b479 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:export (%standard-phases r-build)) @@ -34,12 +35,19 @@ ;; Code: (define (invoke-r command params) - (zero? (apply system* "R" "CMD" command params))) + (apply invoke "R" "CMD" command params)) (define (pipe-to-r command params) (let ((port (apply open-pipe* OPEN_WRITE "R" params))) (display command port) - (zero? (status:exit-val (close-pipe port))))) + (let ((code (status:exit-val (close-pipe port)))) + (unless (zero? code) + (raise (condition ((@@ (guix build utils) &invoke-error) + (program "R") + (arguments (string-append params " " command)) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code))))))))) (define (generate-site-path inputs) (string-join (map (match-lambda @@ -68,13 +76,12 @@ (pkg-name (car (scandir libdir (negate (cut member <> '("." "..")))))) (testdir (string-append libdir pkg-name "/" test-target)) (site-path (string-append libdir ":" (generate-site-path inputs)))) - (if (and tests? (file-exists? testdir)) - (begin - (setenv "R_LIBS_SITE" site-path) - (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " - "lib.loc = \"" libdir "\")") - '("--no-save" "--slave"))) - #t))) + (when (and tests? (file-exists? testdir)) + (setenv "R_LIBS_SITE" site-path) + (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\")") + '("--no-save" "--slave"))) + #t)) (define* (install #:key outputs inputs (configure-flags '()) #:allow-other-keys) @@ -99,6 +106,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (delete 'build) (delete 'check) ; tests must be run after installation diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 09ae2390a5..abef6937bc 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -308,6 +308,7 @@ extended with definitions for VARS." (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (replace 'unpack unpack) (add-before 'build 'extract-gemspec extract-gemspec) diff --git a/guix/build/scons-build-system.scm b/guix/build/scons-build-system.scm index a8760968d8..eb013f03b6 100644 --- a/guix/build/scons-build-system.scm +++ b/guix/build/scons-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,27 +32,27 @@ (define* (build #:key outputs (scons-flags '()) (parallel-build? #t) #:allow-other-keys) (let ((out (assoc-ref outputs "out"))) (mkdir-p out) - (zero? (apply system* "scons" - (append (if parallel-build? - (list "-j" (number->string - (parallel-job-count))) - (list)) - scons-flags))))) + (apply invoke "scons" + (append (if parallel-build? + (list "-j" (number->string + (parallel-job-count))) + (list)) + scons-flags)))) (define* (check #:key tests? test-target (scons-flags '()) #:allow-other-keys) "Run the test suite of a given SCons application." - (cond (tests? - (zero? (apply system* "scons" test-target scons-flags))) - (else - (format #t "test suite not run~%") - #t))) + (if tests? + (apply invoke "scons" test-target scons-flags) + (format #t "test suite not run~%")) + #t) (define* (install #:key outputs (scons-flags '()) #:allow-other-keys) "Install a given SCons application." - (zero? (apply system* "scons" "install" scons-flags))) + (apply invoke "scons" "install" scons-flags)) (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (delete 'configure) (replace 'build build) (replace 'check check) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 31c30edaf5..252d1d4ee5 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> +;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,23 +35,24 @@ (password #f)) "Fetch REVISION from URL into DIRECTORY. REVISION must be an integer, and a valid Subversion revision. Return #t on success, #f otherwise." - (and (zero? (apply system* svn-command - "checkout" "--non-interactive" - ;; Trust the server certificate. This is OK as we - ;; verify the checksum later. This can be removed when - ;; ca-certificates package is added. - "--trust-server-cert" "-r" (number->string revision) - `(,@(if (and user-name password) - (list (string-append "--username=" user-name) - (string-append "--password=" password)) - '()) - ,url ,directory))) - (with-directory-excursion directory - (begin - ;; The contents of '.svn' vary as a function of the current status - ;; of the repo. Since we want a fixed output, this directory needs - ;; to be taken out. - (delete-file-recursively ".svn") - #t)))) + (apply invoke svn-command + "checkout" "--non-interactive" + ;; Trust the server certificate. This is OK as we + ;; verify the checksum later. This can be removed when + ;; ca-certificates package is added. + "--trust-server-cert" "-r" (number->string revision) + `(,@(if (and user-name password) + (list (string-append "--username=" user-name) + (string-append "--password=" password)) + '()) + ,url ,directory)) + + ;; The contents of '.svn' vary as a function of the current status + ;; of the repo. Since we want a fixed output, this directory needs + ;; to be taken out. + (with-directory-excursion directory + (delete-file-recursively ".svn")) + + #t) ;;; svn.scm ends here diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index f6b9b96b87..1c393ecd9d 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -34,11 +34,11 @@ ;; Code: (define (compile-with-latex format file) - (zero? (system* format - "-interaction=batchmode" - "-output-directory=build" - (string-append "&" format) - file))) + (invoke format + "-interaction=batchmode" + "-output-directory=build" + (string-append "&" format) + file)) (define* (configure #:key inputs #:allow-other-keys) (let* ((out (string-append (getcwd) "/.texlive-union")) @@ -81,6 +81,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (delete 'check) diff --git a/guix/build/union.scm b/guix/build/union.scm index 1179f1234b..fff795c4d3 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -27,7 +27,10 @@ #:use-module (rnrs io ports) #:export (union-build - warn-about-collision)) + warn-about-collision + + relative-file-name + symlink-relative)) ;;; Commentary: ;;; @@ -78,14 +81,23 @@ identical, #f otherwise." (or (eof-object? n1) (loop)))))))))))))) +(define %harmless-collisions + ;; This is a list of files that are known to collide, but for which emitting + ;; a warning doesn't make sense. For example, "icon-theme.cache" is + ;; regenerated by a profile hook which shadows the file provided by + ;; individual packages, and "gschemas.compiled" is made available to + ;; applications via 'glib-or-gtk-build-system'. + '("icon-theme.cache" "gschemas.compiled")) + (define (warn-about-collision files) "Handle the collision among FILES by emitting a warning and choosing the first one of THEM." - (format (current-error-port) - "~%warning: collision encountered:~%~{ ~a~%~}" - files) (let ((file (first files))) - (format (current-error-port) "warning: choosing ~a~%" file) + (unless (member (basename file) %harmless-collisions) + (format (current-error-port) + "~%warning: collision encountered:~%~{ ~a~%~}" + files) + (format (current-error-port) "warning: choosing ~a~%" file)) file)) (define* (union-build output inputs @@ -174,4 +186,47 @@ returns #f, skip the faulty file altogether." (union-of-directories output (delete-duplicates inputs))) + +;;; +;;; Relative symlinks. +;;; + +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (relative-file-name reference file) + "Given REFERENCE and FILE, both of which are absolute file names, return the +file name of FILE relative to REFERENCE. + + (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\") + => \"../bin/bar\" + +Note that this is from a purely lexical standpoint; conversely, \"..\" is +*not* resolved lexically on POSIX in the presence of symlinks." + (if (and (string-prefix? "/" file) (string-prefix? "/" reference)) + (let loop ((reference (string-tokenize reference %not-slash)) + (file (string-tokenize file %not-slash))) + (define (finish) + (string-join (append (make-list (length reference) "..") file) + "/")) + + (match reference + (() + (finish)) + ((head . tail) + (match file + (() + (finish)) + ((head* . tail*) + (if (string=? head head*) + (loop tail tail*) + (finish))))))) + file)) + +(define (symlink-relative old new) + "Assuming both OLD and NEW are absolute file names, make NEW a symlink to +OLD, but using a relative file name." + (symlink (relative-file-name (dirname new) old) + new)) + ;;; union.scm ends here diff --git a/guix/build/utils.scm b/guix/build/utils.scm index d7ed3d5177..c58a1afd1c 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,8 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> -;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-60) #:use-module (ice-9 ftw) #:use-module (ice-9 match) @@ -61,6 +63,7 @@ delete-file-recursively file-name-predicate find-files + false-if-file-not-found search-path-as-list set-path-environment-variable @@ -85,7 +88,14 @@ fold-port-matches remove-store-references wrap-program + invoke + invoke-error? + invoke-error-program + invoke-error-arguments + invoke-error-exit-status + invoke-error-term-signal + invoke-error-stop-signal locale-category->string)) @@ -396,6 +406,15 @@ also be included. If FAIL-ON-ERROR? is true, raise an exception upon error." stat) string<?))) +(define-syntax-rule (false-if-file-not-found exp) + "Evaluate EXP but return #f if it raises to 'system-error with ENOENT." + (catch 'system-error + (lambda () exp) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + ;;; ;;; Search paths. @@ -581,13 +600,25 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and ((_ phases (add-after old-phase-name new-phase-name new-phase)) (alist-cons-after old-phase-name new-phase-name new-phase phases)))) +(define-condition-type &invoke-error &error + invoke-error? + (program invoke-error-program) + (arguments invoke-error-arguments) + (exit-status invoke-error-exit-status) + (term-signal invoke-error-term-signal) + (stop-signal invoke-error-stop-signal)) + (define (invoke program . args) - "Invoke PROGRAM with the given ARGS. Raise an error if the exit -code is non-zero; otherwise return #t." - (let ((status (apply system* program args))) - (unless (zero? status) - (error (format #f "program ~s exited with non-zero code" program) - status)) + "Invoke PROGRAM with the given ARGS. Raise an exception +if the exit code is non-zero; otherwise return #t." + (let ((code (apply system* program args))) + (unless (zero? code) + (raise (condition (&invoke-error + (program program) + (arguments args) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code)))))) #t)) diff --git a/guix/build/waf-build-system.scm b/guix/build/waf-build-system.scm index 85f0abcfd6..f0364e867d 100644 --- a/guix/build/waf-build-system.scm +++ b/guix/build/waf-build-system.scm @@ -70,6 +70,7 @@ (define %standard-phases (modify-phases gnu:%standard-phases + (delete 'bootstrap) (replace 'configure configure) (replace 'build build) (replace 'check check) diff --git a/guix/config.scm.in b/guix/config.scm.in index 8f2c4abd8e..aeea81bd3f 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ %store-directory %state-directory + %store-database-directory %config-directory %guix-register-program @@ -80,6 +82,10 @@ (or (getenv "NIX_STATE_DIR") (string-append %localstatedir "/guix"))) +(define %store-database-directory + (or (getenv "NIX_DB_DIR") + (string-append %state-directory "/db"))) + (define %config-directory ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'. (or (getenv "GUIX_CONFIGURATION_DIRECTORY") diff --git a/guix/docker.scm b/guix/docker.scm index a75534c33b..b869901599 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -26,6 +26,7 @@ delete-file-recursively with-directory-excursion invoke)) + #:use-module (json) ;guile-json #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module ((texinfo string-utils) @@ -34,9 +35,6 @@ #:use-module (ice-9 match) #:export (build-docker-image)) -;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co. -(module-use! (current-module) (resolve-interface '(json))) - ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. (define docker-id (compose bytevector->base16-string sha256 string->utf8)) diff --git a/guix/download.scm b/guix/download.scm index 7aa6c03665..988117885c 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -391,11 +391,6 @@ (plain-file "content-addressed-mirrors" (object->string %content-addressed-mirrors))) -(define (gnutls-package) - "Return the default GnuTLS package." - (let ((module (resolve-interface '(gnu packages tls)))) - (module-ref module 'gnutls))) - (define built-in-builders* (let ((cache (make-weak-key-hash-table))) (lambda () @@ -512,12 +507,14 @@ own. This helper makes it easier to deal with \"tar bombs\"." ;; Use ungrafted tar/gzip so that the resulting tarball doesn't depend on ;; whether grafts are enabled. (gexp->derivation (or name file-name) - #~(begin - (mkdir #$output) - (setenv "PATH" (string-append #$gzip "/bin")) - (chdir #$output) - (zero? (system* (string-append #$tar "/bin/tar") - "xf" #$drv))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir #$output) + (setenv "PATH" (string-append #$gzip "/bin")) + (chdir #$output) + (invoke (string-append #$tar "/bin/tar") + "xf" #$drv))) #:graft? #f #:local-build? #t))) @@ -545,11 +542,13 @@ own. This helper makes it easier to deal with \"zip bombs\"." ;; Use ungrafted unzip so that the resulting tarball doesn't depend on ;; whether grafts are enabled. (gexp->derivation (or name file-name) - #~(begin - (mkdir #$output) - (chdir #$output) - (zero? (system* (string-append #$unzip "/bin/unzip") - #$drv))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir #$output) + (chdir #$output) + (invoke (string-append #$unzip "/bin/unzip") + #$drv))) #:graft? #f #:local-build? #t))) diff --git a/guix/gexp.scm b/guix/gexp.scm index d26fad7e0b..153b29bd42 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -33,6 +33,7 @@ #:export (gexp gexp? with-imported-modules + with-extensions gexp-input gexp-input? @@ -118,10 +119,11 @@ ;; "G expressions". (define-record-type <gexp> - (make-gexp references modules proc) + (make-gexp references modules extensions proc) gexp? (references gexp-references) ;list of <gexp-input> (modules gexp-self-modules) ;list of module names + (extensions gexp-self-extensions) ;list of lowerable things (proc gexp-proc)) ;procedure (define (write-gexp gexp port) @@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! <gexp-output> write-gexp-output) -(define (gexp-modules gexp) - "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is -false, meaning that GEXP is a plain Scheme object, return the empty list." +(define (gexp-attribute gexp self-attribute) + "Recurse on GEXP and the expressions it refers to, summing the items +returned by SELF-ATTRIBUTE, a procedure that takes a gexp." (if (gexp? gexp) (delete-duplicates - (append (gexp-self-modules gexp) + (append (self-attribute gexp) (append-map (match-lambda (($ <gexp-input> (? gexp? exp)) - (gexp-modules exp)) + (gexp-attribute exp self-attribute)) (($ <gexp-input> (lst ...)) (append-map (lambda (item) (if (gexp? item) - (gexp-modules item) + (gexp-attribute item + self-attribute) '())) lst)) (_ @@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list." (gexp-references gexp)))) '())) ;plain Scheme data type +(define (gexp-modules gexp) + "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is +false, meaning that GEXP is a plain Scheme object, return the empty list." + (gexp-attribute gexp gexp-self-modules)) + +(define (gexp-extensions gexp) + "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? +GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty +list." + (gexp-attribute gexp gexp-self-extensions)) + (define* (lower-inputs inputs #:key system target) "Turn any package from INPUTS into a derivation for SYSTEM; return the @@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to (modules '()) (module-path %load-path) (guile-for-build (%guile-for-build)) + (effective-version "2.2") (graft? (%graft?)) references-graphs allowed-references disallowed-references @@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). +EFFECTIVE-VERSION determines the string to use when adding extensions of +EXP (see 'with-extensions') to the search path---e.g., \"2.2\". + GRAFT? determines whether packages referred to by EXP should be grafted when applicable. @@ -630,7 +648,7 @@ The other arguments are as for 'derivation'." (define (graphs-file-names graphs) ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. (map (match-lambda - ;; TODO: Remove 'derivation?' special cases. + ;; TODO: Remove 'derivation?' special cases. ((file-name (? derivation? drv)) (cons file-name (derivation->output-path drv))) ((file-name (? derivation? drv) sub-drv) @@ -639,7 +657,13 @@ The other arguments are as for 'derivation'." (cons file-name thing))) graphs)) - (mlet* %store-monad (;; The following binding forces '%current-system' and + (define (extension-flags extension) + `("-L" ,(string-append (derivation->output-path extension) + "/share/guile/site/" effective-version) + "-C" ,(string-append (derivation->output-path extension) + "/lib/guile/" effective-version "/site-ccache"))) + + (mlet* %store-monad ( ;; The following binding forces '%current-system' and ;; '%current-target-system' to be looked up at >>= ;; time. (graft? (set-grafting graft?)) @@ -660,16 +684,24 @@ The other arguments are as for 'derivation'." #:target target)) (builder (text-file script-name (object->string sexp))) + (extensions -> (gexp-extensions exp)) + (exts (mapm %store-monad + (lambda (obj) + (lower-object obj system)) + extensions)) (modules (if (pair? %modules) (imported-modules %modules #:system system #:module-path module-path - #:guile guile-for-build) + #:guile guile-for-build + #:deprecation-warnings + deprecation-warnings) (return #f))) (compiled (if (pair? %modules) (compiled-modules %modules #:system system #:module-path module-path + #:extensions extensions #:guile guile-for-build #:deprecation-warnings deprecation-warnings) @@ -702,6 +734,7 @@ The other arguments are as for 'derivation'." `("-L" ,(derivation->output-path modules) "-C" ,(derivation->output-path compiled)) '()) + ,@(append-map extension-flags exts) ,builder) #:outputs outputs #:env-vars env-vars @@ -711,6 +744,7 @@ The other arguments are as for 'derivation'." ,@(if modules `((,modules) (,compiled) ,@inputs) inputs) + ,@(map list exts) ,@(match graphs (((_ . inputs) ...) inputs) (_ '()))) @@ -859,6 +893,17 @@ environment." (identifier-syntax modules))) body ...)) +(define-syntax-parameter current-imported-extensions + ;; Current list of extensions. + (identifier-syntax '())) + +(define-syntax-rule (with-extensions extensions body ...) + "Mark the gexps defined in BODY... as requiring EXTENSIONS in their +execution environment." + (syntax-parameterize ((current-imported-extensions + (identifier-syntax extensions))) + body ...)) + (define-syntax gexp (lambda (s) (define (collect-escapes exp) @@ -955,6 +1000,7 @@ environment." (refs (map escape->ref escapes))) #`(make-gexp (list #,@refs) current-imported-modules + current-imported-extensions (lambda #,formals #,sexp))))))) @@ -974,7 +1020,15 @@ environment." (define* (imported-files files #:key (name "file-import") (system (%current-system)) - (guile (%guile-for-build))) + (guile (%guile-for-build)) + + ;; XXX: The only reason we have + ;; #:deprecation-warnings is because (guix build + ;; utils), which we use here, relies on _IO*, which + ;; is deprecated in 2.2. On the next full-rebuild + ;; cycle, we should disable such warnings + ;; unconditionally. + (deprecation-warnings #f)) "Return a derivation that imports FILES into STORE. FILES must be a list of (FINAL-PATH . FILE) pairs. Each FILE is mapped to FINAL-PATH in the resulting store path. FILE can be either a file name, or a file-like object, @@ -1010,13 +1064,25 @@ as returned by 'local-file' for example." (gexp->derivation name build #:system system #:guile-for-build guile - #:local-build? #t))) + #:local-build? #t + + ;; TODO: On the next rebuild cycle, set to "no" + ;; unconditionally. + #:env-vars + (case deprecation-warnings + ((#f) + '(("GUILE_WARN_DEPRECATED" . "no"))) + ((detailed) + '(("GUILE_WARN_DEPRECATED" . "detailed"))) + (else + '()))))) (define* (imported-modules modules #:key (name "module-import") (system (%current-system)) (guile (%guile-for-build)) - (module-path %load-path)) + (module-path %load-path) + (deprecation-warnings #f)) "Return a derivation that contains the source files of MODULES, a list of module names such as `(ice-9 q)'. All of MODULES must be either names of modules to be found in the MODULE-PATH search path, or a module name followed @@ -1041,58 +1107,118 @@ last one is created from the given <scheme-file> object." (cons f (search-path* module-path f)))))) modules))) (imported-files files #:name name #:system system - #:guile guile))) + #:guile guile + #:deprecation-warnings deprecation-warnings))) (define* (compiled-modules modules #:key (name "module-import-compiled") (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) + (extensions '()) (deprecation-warnings #f)) "Return a derivation that builds a tree containing the `.go' files corresponding to MODULES. All the MODULES are built in a context where they can refer to each other." + (define total (length modules)) + + (define build-utils-hack? + ;; To avoid a full rebuild, we limit the fix below to the case where + ;; MODULE-PATH is different from %LOAD-PATH. This happens when building + ;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make + ;; this unconditional on the next rebuild cycle. + (and (member '(guix build utils) modules) + (not (equal? module-path %load-path)))) + (mlet %store-monad ((modules (imported-modules modules #:system system #:guile guile #:module-path - module-path))) + module-path + #:deprecation-warnings + deprecation-warnings))) (define build (gexp (begin (primitive-load (ungexp %utils-module)) ;for 'mkdir-p' (use-modules (ice-9 ftw) + (ice-9 format) + (srfi srfi-1) (srfi srfi-26) (system base compile)) (define (regular? file) (not (member file '("." "..")))) - (define (process-directory directory output) + (define (process-entry entry output processed) + (if (file-is-directory? entry) + (let ((output (string-append output "/" (basename entry)))) + (mkdir-p output) + (process-directory entry output processed)) + (let* ((base (basename entry ".scm")) + (output (string-append output "/" base ".go"))) + (format #t "[~2@a/~2@a] Compiling '~a'...~%" + (+ 1 processed) (ungexp total) entry) + (compile-file entry + #:output-file output + #:opts %auto-compilation-options) + (+ 1 processed)))) + + (define (process-directory directory output processed) (let ((entries (map (cut string-append directory "/" <>) (scandir directory regular?)))) - (for-each (lambda (entry) - (if (file-is-directory? entry) - (let ((output (string-append output "/" - (basename entry)))) - (mkdir-p output) - (process-directory entry output)) - (let* ((base (string-drop-right - (basename entry) - 4)) ;.scm - (output (string-append output "/" base - ".go"))) - (compile-file entry - #:output-file output - #:opts - %auto-compilation-options)))) - entries))) + (fold (cut process-entry <> output <>) + processed + entries))) + + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) (else _IOLBF))) + + (ungexp-splicing + (if build-utils-hack? + (gexp ((define mkdir-p + ;; Capture 'mkdir-p'. + (@ (guix build utils) mkdir-p)))) + '())) + + ;; Add EXTENSIONS to the search path. + ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle. + (ungexp-splicing + (if (null? extensions) + '() + (gexp ((set! %load-path + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + '((ungexp-native-splicing extensions))) + %load-path)) + (set! %load-compiled-path + (append (map (lambda (extension) + (string-append extension "/lib/guile/" + (effective-version) + "/site-ccache")) + '((ungexp-native-splicing extensions))) + %load-compiled-path)))))) (set! %load-path (cons (ungexp modules) %load-path)) + + (ungexp-splicing + (if build-utils-hack? + ;; Above we loaded our own (guix build utils) but now we may + ;; need to load a compile a different one. Thus, force a + ;; reload. + (gexp ((let ((utils (ungexp + (file-append modules + "/guix/build/utils.scm")))) + (when (file-exists? utils) + (load utils))))) + '())) + (mkdir (ungexp output)) (chdir (ungexp modules)) - (process-directory "." (ungexp output))))) + (process-directory "." (ungexp output) 0)))) ;; TODO: Pass MODULES as an environment variable. (gexp->derivation name build @@ -1121,20 +1247,34 @@ they can refer to each other." (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.2)) -(define* (load-path-expression modules #:optional (path %load-path)) +(define* (load-path-expression modules #:optional (path %load-path) + #: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) %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) - %load-compiled-path))))))) + (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)) @@ -1143,7 +1283,9 @@ are searched for in PATH." imported modules in its search path. Look up EXP's modules in MODULE-PATH." (mlet %store-monad ((set-load-path (load-path-expression (gexp-modules exp) - module-path))) + module-path + #:extensions + (gexp-extensions exp)))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1172,35 +1314,38 @@ the resulting file. When SET-LOAD-PATH? is true, emit code in the resulting file to set '%load-path' and '%load-compiled-path' to honor EXP's imported modules. Lookup EXP's modules in MODULE-PATH." - (match (if set-load-path? (gexp-modules exp) '()) - (() ;zero modules - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (for-each (lambda (exp) - (write exp port)) - '(ungexp (if splice? - exp - (gexp ((ungexp exp))))))))) - #:local-build? #t - #:substitutable? #f)) - ((modules ...) - (mlet %store-monad ((set-load-path (load-path-expression modules - module-path))) - (gexp->derivation name - (gexp - (call-with-output-file (ungexp output) - (lambda (port) - (write '(ungexp set-load-path) port) - (for-each (lambda (exp) - (write exp port)) - '(ungexp (if splice? - exp - (gexp ((ungexp exp))))))))) - #:module-path module-path - #:local-build? #t - #:substitutable? #f))))) + (define modules (gexp-modules exp)) + (define extensions (gexp-extensions exp)) + + (if (or (not set-load-path?) + (and (null? modules) (null? extensions))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (for-each (lambda (exp) + (write exp port)) + '(ungexp (if splice? + exp + (gexp ((ungexp exp))))))))) + #:local-build? #t + #:substitutable? #f) + (mlet %store-monad ((set-load-path + (load-path-expression modules module-path + #:extensions extensions))) + (gexp->derivation name + (gexp + (call-with-output-file (ungexp output) + (lambda (port) + (write '(ungexp set-load-path) port) + (for-each (lambda (exp) + (write exp port)) + '(ungexp (if splice? + exp + (gexp ((ungexp exp))))))))) + #:module-path module-path + #:local-build? #t + #:substitutable? #f)))) (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing diff --git a/guix/http-client.scm b/guix/http-client.scm index e8a2a23fc5..3b34d4ffba 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -114,7 +114,7 @@ Raise an '&http-get-error' condition if downloading fails." 308) ; permanent redirection (let ((uri (resolve-uri-reference (response-location resp) uri))) (close-port port) - (format #t (G_ "following redirection to `~a'...~%") + (format (current-error-port) (G_ "following redirection to `~a'...~%") (uri->string uri)) (loop uri))) (else diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 58c051e283..08bed8767c 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -88,9 +88,10 @@ "Return the base distribution module for a given module. E.g. the 'ok' module is distributed with 'Test::Simple', so (module->dist-name \"ok\") would return \"Test-Simple\"" - (assoc-ref (json-fetch (string-append "https://fastapi.metacpan.org/v1/module/" - module - "?fields=distribution")) + (assoc-ref (json-fetch-alist (string-append + "https://fastapi.metacpan.org/v1/module/" + module + "?fields=distribution")) "distribution")) (define (package->upstream-name package) @@ -113,7 +114,7 @@ return \"Test-Simple\"" "Return an alist representation of the CPAN metadata for the perl module MODULE, or #f on failure. MODULE should be e.g. \"Test::Script\"" ;; This API always returns the latest release of the module. - (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name))) + (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name))) (define (cpan-home name) (string-append "http://search.cpan.org/dist/" name "/")) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index ec2b7e6029..a5203fe78d 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -25,7 +25,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) - #:use-module (srfi srfi-41) #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) @@ -43,7 +42,7 @@ #:use-module (gnu packages) #:export (cran->guix-package bioconductor->guix-package - recursive-import + cran-recursive-import %cran-updater %bioconductor-updater @@ -128,9 +127,9 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.6. Bioconductor packages should be +;; The latest Bioconductor release is 3.7. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.6") +(define %bioconductor-version "3.7") (define %bioconductor-packages-list-url (string-append "https://bioconductor.org/packages/" @@ -231,13 +230,7 @@ empty list when the FIELD cannot be found." "translations" "utils")) -(define (guix-name name) - "Return a Guix package name for a given R package name." - (string-append "r-" (string-map (match-lambda - (#\_ #\-) - (#\. #\-) - (chr (char-downcase chr))) - name))) +(define cran-guix-name (cut guix-name "r-" <>)) (define (needs-fortran? tarball) "Check if the TARBALL contains Fortran source files." @@ -318,7 +311,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (listify meta "Depends")))))) (values `(package - (name ,(guix-name name)) + (name ,(cran-guix-name name)) (version ,version) (source (origin (method url-fetch) @@ -327,12 +320,12 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (base32 ,(bytevector->nix-base32-string (file-sha256 tarball)))))) ,@(if (not (equal? (string-append "r-" name) - (guix-name name))) + (cran-guix-name name))) `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) '()) (build-system r-build-system) ,@(maybe-inputs sysdepends) - ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs) + ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) ,@(maybe-inputs `(,@(if (needs-fortran? tarball) '("gfortran") '()) @@ -356,63 +349,10 @@ s-expression corresponding to that package, or #f on failure." (and=> (fetch-description repo package-name) (cut description->package repo <>))))) -(define* (recursive-import package-name #:optional (repo 'cran)) - "Generate a stream of package expressions for PACKAGE-NAME and all its -dependencies." - (receive (package . dependencies) - (cran->guix-package package-name repo) - (if (not package) - stream-null - - ;; Generate a lazy stream of package expressions for all unknown - ;; dependencies in the graph. - (let* ((make-state (lambda (queue done) - (cons queue done))) - (next (match-lambda - (((next . rest) . done) next))) - (imported (match-lambda - ((queue . done) done))) - (done? (match-lambda - ((queue . done) - (zero? (length queue))))) - (unknown? (lambda* (dependency #:optional (done '())) - (and (not (member dependency - done)) - (null? (find-packages-by-name - (guix-name dependency)))))) - (update (lambda (state new-queue) - (match state - (((head . tail) . done) - (make-state (lset-difference - equal? - (lset-union equal? new-queue tail) - done) - (cons head done))))))) - (stream-cons - package - (stream-unfold - ;; map: produce a stream element - (lambda (state) - (cran->guix-package (next state) repo)) - - ;; predicate - (negate done?) - - ;; generator: update the queue - (lambda (state) - (receive (package . dependencies) - (cran->guix-package (next state) repo) - (if package - (update state (filter (cut unknown? <> - (cons (next state) - (imported state))) - (car dependencies))) - ;; TODO: Try the other archives before giving up - (update state (imported state))))) - - ;; initial state - (make-state (filter unknown? (car dependencies)) - (list package-name)))))))) +(define* (cran-recursive-import package-name #:optional (repo 'gnu)) + (recursive-import package-name repo + #:repo->guix-package cran->guix-package + #:guix-name cran-guix-name)) ;;; diff --git a/guix/import/crate.scm b/guix/import/crate.scm index a7485bb4d0..3724a457a4 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -51,7 +51,7 @@ (define (crate-kind-predicate kind) (lambda (dep) (string=? (assoc-ref dep "kind") kind))) - (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) + (and-let* ((crate-json (json-fetch-alist (string-append crate-url crate-name))) (crate (assoc-ref crate-json "crate")) (name (assoc-ref crate "name")) (version (assoc-ref crate "max_version")) @@ -63,7 +63,7 @@ string->license) '())) ;missing license info (path (string-append "/" version "/dependencies")) - (deps-json (json-fetch (string-append crate-url name path))) + (deps-json (json-fetch-alist (string-append crate-url name path))) (deps (assoc-ref deps-json "dependencies")) (input-crates (filter (crate-kind-predicate "normal") deps)) (native-input-crates diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 43e9eb60c9..65e0be45ab 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,7 +38,8 @@ #:use-module (guix packages) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package - %elpa-updater)) + %elpa-updater + elpa-recursive-import)) (define (elpa-dependencies->names deps) "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of @@ -200,13 +202,15 @@ type '<elpa-package>'." (define source-url (elpa-package-source-url pkg)) + (define dependencies-names + (filter-dependencies (elpa-dependencies->names + (elpa-package-inputs pkg)))) + (define dependencies - (let* ((deps (elpa-package-inputs pkg)) - (names (filter-dependencies (elpa-dependencies->names deps)))) - (map (lambda (n) - (let ((new-n (elpa-name->package-name n))) - (list new-n (list 'unquote (string->symbol new-n))))) - names))) + (map (lambda (n) + (let ((new-n (elpa-name->package-name n))) + (list new-n (list 'unquote (string->symbol new-n))))) + dependencies-names)) (define (maybe-inputs input-type inputs) (match inputs @@ -218,23 +222,25 @@ type '<elpa-package>'." (let ((tarball (with-store store (download-to-store store source-url)))) - `(package - (name ,(elpa-name->package-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) - (sha256 - (base32 - ,(if tarball - (bytevector->nix-base32-string (file-sha256 tarball)) - "failed to download package"))))) - (build-system emacs-build-system) - ,@(maybe-inputs 'propagated-inputs dependencies) - (home-page ,(elpa-package-home-page pkg)) - (synopsis ,(elpa-package-synopsis pkg)) - (description ,(elpa-package-description pkg)) - (license ,license)))) + (values + `(package + (name ,(elpa-name->package-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(if tarball + (bytevector->nix-base32-string (file-sha256 tarball)) + "failed to download package"))))) + (build-system emacs-build-system) + ,@(maybe-inputs 'propagated-inputs dependencies) + (home-page ,(elpa-package-home-page pkg)) + (synopsis ,(elpa-package-synopsis pkg)) + (description ,(elpa-package-description pkg)) + (license ,license)) + dependencies-names))) (define* (elpa->guix-package name #:optional (repo 'gnu)) "Fetch the package NAME from REPO and produce a Guix package S-expression." @@ -289,4 +295,11 @@ type '<elpa-package>'." (pred package-from-gnu.org?) (latest latest-release))) +(define elpa-guix-name (cut guix-name "emacs-" <>)) + +(define* (elpa-recursive-import package-name #:optional (repo 'gnu)) + (recursive-import package-name repo + #:repo->guix-package elpa->guix-package + #:guix-name elpa-guix-name)) + ;;; elpa.scm ends here diff --git a/guix/import/gem.scm b/guix/import/gem.scm index 6e914d6290..646163fb7b 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -38,7 +38,7 @@ (define (rubygems-fetch name) "Return an alist representation of the RubyGems metadata for the package NAME, or #f on failure." - (json-fetch + (json-fetch-alist (string-append "https://rubygems.org/api/v1/gems/" name ".json"))) (define (ruby-package-name name) diff --git a/guix/import/github.scm b/guix/import/github.scm index 4b7d53c704..ef226911b9 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -22,31 +22,16 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) - #:use-module (json) #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) + #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix http-client) #:use-module (web uri) #:export (%github-updater)) -(define (json-fetch* url) - "Return a representation of the JSON resource URL (a list or hash table), or -#f if URL returns 403 or 404." - (guard (c ((and (http-get-error? c) - (let ((error (http-get-error-code c))) - (or (= 403 error) - (= 404 error)))) - #f)) ;; "expected" if there is an authentification error (403), - ;; or if package is unknown (404). - ;; Note: github.com returns 403 if we omit a 'User-Agent' header. - (let* ((port (http-fetch url)) - (result (json->scm port))) - (close-port port) - result))) - (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" @@ -144,7 +129,7 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" "https://api.github.com/repos/" (github-user-slash-repository url) "/releases")) - (json (json-fetch* + (json (json-fetch (if token (string-append api-url "?access_token=" token) api-url)))) diff --git a/guix/import/json.scm b/guix/import/json.scm index c76bc9313c..3f2ab1e3ea 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -22,15 +22,25 @@ #:use-module (guix http-client) #:use-module (guix import utils) #:use-module (srfi srfi-34) - #:export (json-fetch)) + #:export (json-fetch + json-fetch-alist)) (define (json-fetch url) - "Return an alist representation of the JSON resource URL, or #f on failure." + "Return a representation of the JSON resource URL (a list or hash table), or +#f if URL returns 403 or 404." (guard (c ((and (http-get-error? c) - (= 404 (http-get-error-code c))) - #f)) ;"expected" if package is unknown - (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile") - (Accept . "application/json")))) - (result (hash-table->alist (json->scm port)))) + (let ((error (http-get-error-code c))) + (or (= 403 error) + (= 404 error)))) + #f)) + ;; Note: many websites returns 403 if we omit a 'User-Agent' header. + (let* ((port (http-fetch url #:headers '((user-agent . "GNU Guile") + (Accept . "application/json")))) + (result (json->scm port))) (close-port port) result))) + +(define (json-fetch-alist url) + "Return an alist representation of the JSON resource URL, or #f if URL +returns 403 or 404." + (hash-table->alist (json-fetch url))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index bb0db1ba85..6beab6b010 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -51,8 +51,8 @@ (define (pypi-fetch name) "Return an alist representation of the PyPI metadata for the package NAME, or #f on failure." - (json-fetch (string-append "https://pypi.python.org/pypi/" - name "/json"))) + (json-fetch-alist (string-append "https://pypi.python.org/pypi/" + name "/json"))) ;; For packages found on PyPI that lack a source distribution. (define-condition-type &missing-source-error &error diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 5b25adc674..ec93fbced6 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -60,7 +60,7 @@ (let* ((url (if (string=? "" version) (string-append %stackage-url "/lts") (string-append %stackage-url "/lts-" version))) - (lts-info (json-fetch url))) + (lts-info (json-fetch-alist url))) (if lts-info (reverse lts-info) (leave-with-message "LTS release version not found: ~a" version)))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index efc6169077..df85904c6f 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,6 +40,8 @@ #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) #:export (factorize-uri hash-table->alist @@ -61,7 +64,11 @@ alist->package read-lines - chunk-lines)) + chunk-lines + + guix-name + + recursive-import)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -357,3 +364,71 @@ separated by PRED." (if (null? after) (reverse res) (loop (cdr after) res)))))) + +(define (guix-name prefix name) + "Return a Guix package name for a given package name." + (string-append prefix (string-map (match-lambda + (#\_ #\-) + (#\. #\-) + (chr (char-downcase chr))) + name))) + +(define* (recursive-import package-name repo + #:key repo->guix-package guix-name + #:allow-other-keys) + "Generate a stream of package expressions for PACKAGE-NAME and all its +dependencies." + (receive (package . dependencies) + (repo->guix-package package-name repo) + (if (not package) + stream-null + + ;; Generate a lazy stream of package expressions for all unknown + ;; dependencies in the graph. + (let* ((make-state (lambda (queue done) + (cons queue done))) + (next (match-lambda + (((next . rest) . done) next))) + (imported (match-lambda + ((queue . done) done))) + (done? (match-lambda + ((queue . done) + (zero? (length queue))))) + (unknown? (lambda* (dependency #:optional (done '())) + (and (not (member dependency + done)) + (null? (find-packages-by-name + (guix-name dependency)))))) + (update (lambda (state new-queue) + (match state + (((head . tail) . done) + (make-state (lset-difference + equal? + (lset-union equal? new-queue tail) + done) + (cons head done))))))) + (stream-cons + package + (stream-unfold + ;; map: produce a stream element + (lambda (state) + (repo->guix-package (next state) repo)) + + ;; predicate + (negate done?) + + ;; generator: update the queue + (lambda (state) + (receive (package . dependencies) + (repo->guix-package package-name repo) + (if package + (update state (filter (cut unknown? <> + (cons (next state) + (imported state))) + (car dependencies))) + ;; TODO: Try the other archives before giving up + (update state (imported state))))) + + ;; initial state + (make-state (filter unknown? (car dependencies)) + (list package-name)))))))) diff --git a/guix/man-db.scm b/guix/man-db.scm index 732aef1083..4cef874f8b 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (guix man-db) #:use-module (guix zlib) #:use-module ((guix build utils) #:select (find-files)) + #:use-module (gdbm) ;gdbm-ffi #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -44,9 +45,6 @@ ;;; ;;; Code: -;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co. -(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT)) - (define-record-type <mandb-entry> (mandb-entry file-name name section synopsis kind) mandb-entry? diff --git a/guix/packages.scm b/guix/packages.scm index b5c0b60440..c762fa7c39 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2014, 2015, 2017 Mark H Weaver <mhw@netris.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> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> @@ -35,6 +35,7 @@ #:use-module (guix sets) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) @@ -106,6 +107,7 @@ package-cross-derivation package-output package-grafts + package-patched-vulnerabilities package/inherit transitive-input-references @@ -388,10 +390,37 @@ object." (define-condition-type &package-cross-build-system-error &package-error package-cross-build-system-error?) - -(define (package-full-name package) - "Return the full name of PACKAGE--i.e., `NAME-VERSION'." - (string-append (package-name package) "-" (package-version package))) +(define* (package-full-name package #:optional (delimiter "@")) + "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying +DELIMITER (a string), you can customize what will appear between the name and +the version. By default, DELIMITER is \"@\"." + (string-append (package-name package) delimiter (package-version package))) + +(define (patch-file-name patch) + "Return the basename of PATCH's file name, or #f if the file name could not +be determined." + (match patch + ((? string?) + (basename patch)) + ((? origin?) + (and=> (origin-actual-file-name patch) basename)))) + +(define %vulnerability-regexp + ;; Regexp matching a CVE identifier in patch file names. + (make-regexp "CVE-[0-9]{4}-[0-9]+")) + +(define (package-patched-vulnerabilities package) + "Return the list of patched vulnerabilities of PACKAGE as a list of CVE +identifiers. The result is inferred from the file names of patches." + (define (patch-vulnerabilities patch) + (map (cut match:substring <> 0) + (list-matches %vulnerability-regexp patch))) + + (let ((patches (filter-map patch-file-name + (or (and=> (package-source package) + origin-patches) + '())))) + (append-map patch-vulnerabilities patches))) (define (%standard-patch-inputs) (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) @@ -519,9 +548,9 @@ specifies modules in scope when evaluating SNIPPET." ;; Use '--force' so that patches that do not apply perfectly are ;; rejected. Use '--no-backup-if-mismatch' to prevent making ;; "*.orig" file if a patch is applied with offset. - (zero? (system* (string-append #+patch "/bin/patch") - "--force" "--no-backup-if-mismatch" - #+@flags "--input" patch))) + (invoke (string-append #+patch "/bin/patch") + "--force" "--no-backup-if-mismatch" + #+@flags "--input" patch)) (define (first-file directory) ;; Return the name of the first file in DIRECTORY. @@ -546,64 +575,74 @@ specifies modules in scope when evaluating SNIPPET." #+decomp "/bin")) ;; SOURCE may be either a directory or a tarball. - (and (if (file-is-directory? #+source) - (let* ((store (%store-directory)) - (len (+ 1 (string-length store))) - (base (string-drop #+source len)) - (dash (string-index base #\-)) - (directory (string-drop base (+ 1 dash)))) - (mkdir directory) - (copy-recursively #+source directory) - #t) - #+(if (string=? decompression-type "unzip") - #~(zero? (system* "unzip" #+source)) - #~(zero? (system* (string-append #+tar "/bin/tar") - "xvf" #+source)))) - (let ((directory (first-file "."))) - (format (current-error-port) - "source is under '~a'~%" directory) - (chdir directory) - - (and (every apply-patch '#+patches) - #+@(if snippet - #~((let ((module (make-fresh-user-module))) - (module-use-interfaces! - module - (map resolve-interface '#+modules)) - ((@ (system base compile) compile) - '#+snippet - #:to 'value - #:opts %auto-compilation-options - #:env module))) - #~()) - - (begin (chdir "..") #t) - - (unless tar-supports-sort? - (call-with-output-file ".file_list" - (lambda (port) - (for-each (lambda (name) - (format port "~a~%" name)) - (find-files directory - #:directories? #t - #:fail-on-error? #t))))) - (zero? (apply system* - (string-append #+tar "/bin/tar") - "cvf" #$output - ;; The bootstrap xz does not support - ;; threaded compression (introduced in - ;; 5.2.0), but it ignores the extra flag. - (string-append "--use-compress-program=" - #+xz "/bin/xz --threads=0") - ;; avoid non-determinism in the archive - "--mtime=@0" - "--owner=root:0" - "--group=root:0" - (if tar-supports-sort? - `("--sort=name" - ,directory) - '("--no-recursion" - "--files-from=.file_list")))))))))) + (if (file-is-directory? #+source) + (let* ((store (%store-directory)) + (len (+ 1 (string-length store))) + (base (string-drop #+source len)) + (dash (string-index base #\-)) + (directory (string-drop base (+ 1 dash)))) + (mkdir directory) + (copy-recursively #+source directory)) + #+(if (string=? decompression-type "unzip") + #~(invoke "unzip" #+source) + #~(invoke (string-append #+tar "/bin/tar") + "xvf" #+source))) + + (let ((directory (first-file "."))) + (format (current-error-port) + "source is under '~a'~%" directory) + (chdir directory) + + (for-each apply-patch '#+patches) + + (let ((result #+(if snippet + #~(let ((module (make-fresh-user-module))) + (module-use-interfaces! + module + (map resolve-interface '#+modules)) + ((@ (system base compile) compile) + '#+snippet + #:to 'value + #:opts %auto-compilation-options + #:env module)) + #~#t))) + ;; Issue a warning unless the result is #t. + (unless (eqv? result #t) + (format (current-error-port) "\ +## WARNING: the snippet returned `~s'. Return values other than #t +## are deprecated. Please migrate this package so that its snippet +## reports errors by raising an exception, and otherwise returns #t.~%" + result)) + (unless result + (error "snippet returned false"))) + + (chdir "..") + + (unless tar-supports-sort? + (call-with-output-file ".file_list" + (lambda (port) + (for-each (lambda (name) + (format port "~a~%" name)) + (find-files directory + #:directories? #t + #:fail-on-error? #t))))) + (apply invoke + (string-append #+tar "/bin/tar") + "cvf" #$output + ;; The bootstrap xz does not support + ;; threaded compression (introduced in + ;; 5.2.0), but it ignores the extra flag. + (string-append "--use-compress-program=" + #+xz "/bin/xz --threads=0") + ;; avoid non-determinism in the archive + "--mtime=@0" + "--owner=root:0" + "--group=root:0" + (if tar-supports-sort? + `("--sort=name" + ,directory) + '("--no-recursion" + "--files-from=.file_list"))))))) (let ((name (tarxz-name original-file-name))) (gexp->derivation name build @@ -935,6 +974,10 @@ and return it." (($ <package> name version source build-system args inputs propagated-inputs native-inputs self-native-input? outputs) + ;; Even though we prefer to use "@" to separate the package + ;; name from the package version in various user-facing parts + ;; of Guix, checkStoreName (in nix/libstore/store-api.cc) + ;; prohibits the use of "@", so use "-" instead. (or (make-bag build-system (string-append name "-" version) #:system system #:target target diff --git a/guix/profiles.scm b/guix/profiles.scm index 95dc9746bd..ebd7da2a24 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -25,6 +25,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix profiles) + #:use-module ((guix config) #:select (%state-directory)) #:use-module ((guix utils) #:hide (package-name->name+version)) #:use-module ((guix build utils) #:select (package-name->name+version)) @@ -77,6 +78,7 @@ manifest-entry-dependencies manifest-entry-search-paths manifest-entry-parent + manifest-entry-properties manifest-pattern manifest-pattern? @@ -118,7 +120,13 @@ generation-file-name switch-to-generation roll-back - delete-generation)) + delete-generation + + %user-profile-directory + %profile-directory + %current-profile + canonicalize-profile + user-friendly-profile)) ;;; Commentary: ;;; @@ -168,13 +176,15 @@ (version manifest-entry-version) ; string (output manifest-entry-output ; string (default "out")) - (item manifest-entry-item) ; package | store path + (item manifest-entry-item) ; package | file-like | store path (dependencies manifest-entry-dependencies ; <manifest-entry>* (default '())) (search-paths manifest-entry-search-paths ; search-path-specification* (default '())) (parent manifest-entry-parent ; promise (#f | <manifest-entry>) - (default (delay #f)))) + (default (delay #f))) + (properties manifest-entry-properties ; list of symbol/value pairs + (default '()))) (define-record-type* <manifest-pattern> manifest-pattern make-manifest-pattern @@ -313,18 +323,20 @@ denoting a specific output of a package." (define (entry->gexp entry) (match entry (($ <manifest-entry> name version output (? string? path) - (deps ...) (search-paths ...)) + (deps ...) (search-paths ...) _ (properties ...)) #~(#$name #$version #$output #$path (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp - search-paths)))) - (($ <manifest-entry> name version output (? package? package) - (deps ...) (search-paths ...)) + search-paths)) + (properties . #$properties))) + (($ <manifest-entry> name version output package + (deps ...) (search-paths ...) _ (properties ...)) #~(#$name #$version #$output (ungexp package (or output "out")) (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp - search-paths)))))) + search-paths)) + (properties . #$properties))))) (match manifest (($ <manifest> (entries ...)) @@ -387,7 +399,9 @@ procedure is here for backward-compatibility and will eventually vanish." (dependencies deps*) (search-paths (map sexp->search-path-specification search-paths)) - (parent parent)))) + (parent parent) + (properties (or (assoc-ref extra-stuff 'properties) + '()))))) entry)))) (match sexp @@ -671,7 +685,13 @@ if not found." (return (find-among-inputs inputs))))) ((? string? item) (mlet %store-monad ((refs (references* item))) - (return (find-among-store-items refs))))))) + (return (find-among-store-items refs)))) + (item + ;; XXX: ITEM might be a 'computed-file' or anything like that, in + ;; which case we don't know what to do. The fix may be to check + ;; references once ITEM is compiled, as proposed at + ;; <https://bugs.gnu.org/29927>. + (return #f))))) (anym %store-monad entry-lookup-package (manifest-entries manifest))) @@ -837,6 +857,57 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." #:local-build? #t #:substitutable? #f)) +(define (glib-schemas manifest) + "Return a derivation that unions all schemas from manifest entries and +creates the Glib 'gschemas.compiled' file." + (define glib ; lazy reference + (module-ref (resolve-interface '(gnu packages glib)) 'glib)) + + (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib")) + ;; XXX: Can't use glib-compile-schemas corresponding + ;; to the glib referenced by 'manifest'. Because + ;; '%glib' can be either a package or store path, and + ;; there's no way to get the "bin" output for the later. + (glib-compile-schemas + -> #~(string-append #+glib:bin + "/bin/glib-compile-schemas"))) + + (define build + (with-imported-modules '((guix build utils) + (guix build union) + (guix build profiles) + (guix search-paths) + (guix records)) + #~(begin + (use-modules (guix build utils) + (guix build union) + (guix build profiles) + (srfi srfi-26)) + + (let* ((destdir (string-append #$output "/share/glib-2.0/schemas")) + (schemadirs (filter file-exists? + (map (cut string-append <> "/share/glib-2.0/schemas") + '#$(manifest-inputs manifest))))) + + ;; Union all the schemas. + (mkdir-p (string-append #$output "/share/glib-2.0")) + (union-build destdir schemadirs + #:log-port (%make-void-port "w")) + + (let ((dir destdir)) + (when (file-is-directory? dir) + (ensure-writable-directory dir) + (invoke #+glib-compile-schemas + (string-append "--targetdir=" dir) + dir))))))) + + ;; Don't run the hook when there's nothing to do. + (if %glib + (gexp->derivation "glib-schemas" build + #:local-build? #t + #:substitutable? #f) + (return #f)))) + (define (gtk-icon-themes manifest) "Return a derivation that unions all icon themes from manifest entries and creates the GTK+ 'icon-theme.cache' file for each theme." @@ -1139,41 +1210,39 @@ the entries in MANIFEST." (define build (with-imported-modules modules - #~(begin - (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/" - (effective-version))) - - (use-modules (guix man-db) - (guix build utils) - (srfi srfi-1) - (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))) - - (define man-directory - (string-append #$output "/share/man")) - - (mkdir-p man-directory) - - (format #t "Creating manual page database...~%") - (force-output) - (let* ((start (current-time)) - (entries (compute-entries)) - (_ (write-mandb-database (string-append man-directory - "/index.db") - entries)) - (duration (time-difference (current-time) start))) - (format #t "~a entries processed in ~,1f s~%" - (length entries) - (+ (time-second duration) - (* (time-nanosecond duration) (expt 10 -9)))) - (force-output))))) + (with-extensions (list gdbm-ffi) ;for (guix man-db) + #~(begin + (use-modules (guix man-db) + (guix build utils) + (srfi srfi-1) + (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))) + + (define man-directory + (string-append #$output "/share/man")) + + (mkdir-p man-directory) + + (format #t "Creating manual page database...~%") + (force-output) + (let* ((start (current-time)) + (entries (compute-entries)) + (_ (write-mandb-database (string-append man-directory + "/index.db") + entries)) + (duration (time-difference (current-time) start))) + (format #t "~a entries processed in ~,1f s~%" + (length entries) + (+ (time-second duration) + (* (time-nanosecond duration) (expt 10 -9)))) + (force-output)))))) (gexp->derivation "manual-database" build @@ -1192,6 +1261,7 @@ the entries in MANIFEST." fonts-dir-file ghc-package-cache-file ca-certificate-bundle + glib-schemas gtk-icon-themes gtk-im-modules xdg-desktop-database @@ -1202,6 +1272,7 @@ the entries in MANIFEST." (hooks %default-profile-hooks) (locales? #t) (allow-collisions? #f) + (relative-symlinks? #f) system target) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by @@ -1213,6 +1284,9 @@ with a different version number.) When LOCALES? is true, the build is performed under a UTF-8 locale; this adds a dependency on the 'glibc-utf8-locales' package. +When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets. +This is one of the things to do for the result to be relocatable. + When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST are cross-built for TARGET." (mlet* %store-monad ((system (if system @@ -1275,6 +1349,9 @@ are cross-built for TARGET." (manifest-entries manifest)))))) (build-profile #$output '#$inputs + #:symlink #$(if relative-symlinks? + #~symlink-relative + #~symlink) #:manifest '#$(manifest->gexp manifest) #:search-paths search-paths)))) @@ -1452,4 +1529,44 @@ because the NUMBER is zero.)" (else (delete-and-return))))) +(define %user-profile-directory + (and=> (getenv "HOME") + (cut string-append <> "/.guix-profile"))) + +(define %profile-directory + (string-append %state-directory "/profiles/" + (or (and=> (or (getenv "USER") + (getenv "LOGNAME")) + (cut string-append "per-user/" <>)) + "default"))) + +(define %current-profile + ;; Call it `guix-profile', not `profile', to allow Guix profiles to + ;; coexist with Nix profiles. + (string-append %profile-directory "/guix-profile")) + +(define (canonicalize-profile profile) + "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise +return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if +'-p' was omitted." ; see <http://bugs.gnu.org/17939> + + ;; Trim trailing slashes so that the basename comparison below works as + ;; intended. + (let ((profile (string-trim-right profile #\/))) + (if (and %user-profile-directory + (string=? (canonicalize-path (dirname profile)) + (dirname %user-profile-directory)) + (string=? (basename profile) (basename %user-profile-directory))) + %current-profile + profile))) + +(define (user-friendly-profile profile) + "Return either ~/.guix-profile if that's what PROFILE refers to, directly or +indirectly, or PROFILE." + (if (and %user-profile-directory + (false-if-exception + (string=? (readlink %user-profile-directory) profile))) + %user-profile-directory + profile)) + ;;; profiles.scm ends here diff --git a/guix/records.scm b/guix/records.scm index c02395f2ae..da3ecdaaf8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -52,13 +52,48 @@ ((weird _ ...) ;weird! (syntax-violation name "invalid field specifier" #'weird))))) +(define (print-record-abi-mismatch-error port key args + default-printer) + (match args + ((rtd . _) + ;; The source file where this exception is thrown must be recompiled. + (format port "ERROR: ~a: record ABI mismatch; recompilation needed" + rtd)))) + +(set-exception-printer! 'record-abi-mismatch-error + print-record-abi-mismatch-error) + +(eval-when (expand load eval) + ;; The procedures below are needed both at run time and at expansion time. + + (define (current-abi-identifier type) + "Return an identifier unhygienically derived from TYPE for use as its +\"current ABI\" variable." + (let ((type-name (syntax->datum type))) + (datum->syntax + type + (string->symbol + (string-append "% " (symbol->string type-name) + " abi-cookie"))))) + + (define (abi-check type cookie) + "Return syntax that checks that the current \"application binary +interface\" (ABI) for TYPE is equal to COOKIE." + (with-syntax ((current-abi (current-abi-identifier type))) + #`(unless (eq? current-abi #,cookie) + (throw 'record-abi-mismatch-error #,type))))) + (define-syntax make-syntactic-constructor (syntax-rules () "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects all of EXPECTED fields to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked -fields, and DELAYED is the list of identifiers of delayed fields." +fields, and DELAYED is the list of identifiers of delayed fields. + +ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI +of TYPE matches the expansion-time ABI." ((_ type name ctor (expected ...) + #:abi-cookie abi-cookie #:thunked thunked #:delayed delayed #:innate innate @@ -130,6 +165,7 @@ fields, and DELAYED is the list of identifiers of delayed fields." (syntax-case s (inherit expected ...) ((_ (inherit orig-record) (field value) (... ...)) #`(let* #,(field-bindings #'((field value) (... ...))) + #,(abi-check #'type abi-cookie) #,(record-inheritance #'orig-record #'((field value) (... ...))))) ((_ (field value) (... ...)) @@ -144,6 +180,7 @@ fields, and DELAYED is the list of identifiers of delayed fields." (cond ((lset= eq? fields '(expected ...)) #`(let* #,(field-bindings #'((field value) (... ...))) + #,(abi-check #'type abi-cookie) (ctor #,@(map field-value '(expected ...))))) ((pair? (lset-difference eq? fields '(expected ...))) @@ -270,6 +307,16 @@ inherited." ;; The real value of that field is a promise, so force it. (force (real-get x))))))) + (define (compute-abi-cookie field-specs) + ;; Compute an "ABI cookie" for the given FIELD-SPECS. We use + ;; 'string-hash' because that's a better hash function that 'hash' on a + ;; list of symbols. + (syntax-case field-specs () + (((field get properties ...) ...) + (string-hash (object->string + (syntax->datum #'((field properties ...) ...))) + most-positive-fixnum)))) + (syntax-case s () ((_ type syntactic-ctor ctor pred (field get properties ...) ...) @@ -278,7 +325,8 @@ inherited." (delayed (filter-map delayed-field? field-spec)) (innate (filter-map innate-field? field-spec)) (defaults (filter-map field-default-value - #'((field properties ...) ...)))) + #'((field properties ...) ...))) + (cookie (compute-abi-cookie field-spec))) (with-syntax (((field-spec* ...) (map field-spec->srfi-9 field-spec)) ((thunked-field-accessor ...) @@ -298,10 +346,13 @@ inherited." (ctor field ...) pred field-spec* ...) + (define #,(current-abi-identifier #'type) + #,cookie) thunked-field-accessor ... delayed-field-accessor ... (make-syntactic-constructor type syntactic-ctor ctor (field ...) + #:abi-cookie #,cookie #:thunked #,thunked #:delayed #,delayed #:innate #,innate diff --git a/guix/scripts.scm b/guix/scripts.scm index 4a7ae7baa3..4cbbbeb96f 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; @@ -170,7 +170,7 @@ Show what and how will/would be built." (define age (match (false-if-not-found (lstat (string-append (config-directory #:ensure? #f) - "/latest"))) + "/current"))) (#f #f) (stat (- (time-second (current-time time-utc)) (stat:mtime stat))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 401087e830..4dd4fbccdf 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -661,43 +661,47 @@ build." (define system (assoc-ref opts 'system)) (define graft? (assoc-ref opts 'graft?)) - (parameterize ((%graft? graft?)) - (append-map (match-lambda - ((? package? p) - (let ((p (or (and graft? (package-replacement p)) p))) - (match src - (#f - (list (package->derivation store p system))) - (#t - (match (package-source p) - (#f - (format (current-error-port) - (G_ "~a: warning: \ + ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields + ;; of user packages. Since 'guix build' is the primary tool for people + ;; testing new packages, report such errors gracefully. + (with-unbound-variable-handling + (parameterize ((%graft? graft?)) + (append-map (match-lambda + ((? package? p) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (match (package-source p) + (#f + (format (current-error-port) + (G_ "~a: warning: \ package '~a' has no source~%") - (location->string (package-location p)) - (package-name p)) - '()) - (s - (list (package-source-derivation store s))))) - (proc - (map (cut package-source-derivation store <>) - (proc p)))))) - ((? derivation? drv) - (list drv)) - ((? procedure? proc) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (proc)) - #:system system))) - ((? gexp? gexp) - (list (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (gexp->derivation "gexp" gexp - #:system system)))))) - (map (cut transform store <>) - (options->things-to-build opts))))) + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) + ((? derivation? drv) + (list drv)) + ((? procedure? proc) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (proc)) + #:system system))) + ((? gexp? gexp) + (list (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (gexp->derivation "gexp" gexp + #:system system)))))) + (map (cut transform store <>) + (options->things-to-build opts)))))) (define (show-build-log store file urls) "Show the build log for FILE, falling back to remote logs from URLS if diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index d65c644c05..30ae6d4342 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -99,8 +99,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) `(define-public ,(string->symbol name) ,pkg)) (_ #f)) - (reverse (stream->list (recursive-import package-name - (or (assoc-ref opts 'repo) 'cran))))) + (reverse + (stream->list + (cran-recursive-import package-name + (or (assoc-ref opts 'repo) 'cran))))) ;; Single import (let ((sexp (cran->guix-package package-name (or (assoc-ref opts 'repo) 'cran)))) diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm index 34eb16485e..f1ed5016ba 100644 --- a/guix/scripts/import/elpa.scm +++ b/guix/scripts/import/elpa.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,10 +22,12 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import elpa) + #:use-module (guix import utils) #:use-module (guix scripts import) #: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-elpa)) @@ -45,6 +48,8 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive generate package expressions for all Emacs packages that are not yet in Guix")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -62,6 +67,9 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (lambda (opt name arg result) (alist-cons 'repo (string->symbol arg) (alist-delete 'repo result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -87,10 +95,20 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) - (unless sexp - (leave (G_ "failed to download package '~a'~%") package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (elpa-recursive-import package-name + (or (assoc-ref opts 'repo) 'gnu))))) + (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo)))) + (unless sexp + (leave (G_ "failed to download package '~a'~%") package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4ec3267007..e477bf0ddc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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> @@ -809,15 +809,6 @@ descriptions maintained upstream." (emit-warning package (G_ "invalid license field") 'license)))) -(define (patch-file-name patch) - "Return the basename of PATCH's file name, or #f if the file name could not -be determined." - (match patch - ((? string?) - (basename patch)) - ((? origin?) - (and=> (origin-actual-file-name patch) basename)))) - (define (call-with-networking-fail-safe message error-value proc) "Call PROC catching any network-related errors. Upon a networking error, display a message including MESSAGE and return ERROR-VALUE." @@ -878,20 +869,14 @@ the NIST server non-fatal." (() #t) ((vulnerabilities ...) - (let* ((patches (filter-map patch-file-name - (or (and=> (package-source package) - origin-patches) - '()))) + (let* ((patched (package-patched-vulnerabilities package)) (known-safe (or (assq-ref (package-properties package) 'lint-hidden-cve) '())) (unpatched (remove (lambda (vuln) (let ((id (vulnerability-id vuln))) - (or - (find (cute string-contains - <> id) - patches) - (member id known-safe)))) + (or (member id patched) + (member id known-safe)))) vulnerabilities))) (unless (null? unpatched) (emit-warning package @@ -1037,7 +1022,7 @@ them for PACKAGE." (check check-inputs-should-be-native)) (lint-checker (name 'inputs-should-not-be-input) - (description "Identify inputs that should be inputs at all") + (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) (lint-checker (name 'patch-file-names) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 56d6de6308..fb61d7c059 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -494,6 +494,30 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (() (values #f #f)))))) +(define (call-with-timeout timeout drv thunk) + "Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call +THUNK. Use DRV as an indication of what we were building when the timeout +expired." + (if (number? timeout) + (dynamic-wind + (lambda () + (sigaction SIGALRM + (lambda _ + ;; The exit code here will be 1, which guix-daemon will + ;; interpret as a transient failure. + (leave (G_ "timeout expired while offloading '~a'~%") + (derivation-file-name drv)))) + (alarm timeout)) + thunk + (lambda () + (alarm 0))) + (thunk))) + +(define-syntax-rule (with-timeout timeout drv exp ...) + "Evaluate EXP... and leave after TIMEOUT seconds if EXP hasn't completed. +If TIMEOUT is #f, simply evaluate EXP..." + (call-with-timeout timeout drv (lambda () exp ...))) + (define* (process-request wants-local? system drv features #:key print-build-trace? (max-silent-time 3600) @@ -520,13 +544,18 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (display "# accept\n") (let ((inputs (string-tokenize (read-line))) (outputs (string-tokenize (read-line)))) - (transfer-and-offload drv machine - #:inputs inputs - #:outputs outputs - #:max-silent-time max-silent-time - #:build-timeout build-timeout - #:print-build-trace? - print-build-trace?))) + ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can + ;; be issues with the connection or deadlocks that could + ;; lead the 'guix offload' process to remain stuck forever. + ;; To avoid that, install a timeout here as well. + (with-timeout build-timeout drv + (transfer-and-offload drv machine + #:inputs inputs + #:outputs outputs + #:max-silent-time max-silent-time + #:build-timeout build-timeout + #:print-build-trace? + print-build-trace?)))) (lambda () (release-build-slot slot))) @@ -755,6 +784,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) ;;; 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) ;;; End: ;;; offload.scm ends here diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 488638adc5..76729d8e10 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il> -;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; @@ -32,17 +32,20 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system gnu) #:use-module (guix scripts build) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (gnu packages compression) #:use-module (gnu packages guile) - #:autoload (gnu packages base) (tar) + #:use-module (gnu packages base) #:autoload (gnu packages package-management) (guix) #:autoload (gnu packages gnupg) (libgcrypt) #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (compressor? @@ -90,7 +93,7 @@ found." (compressor (first %compressors)) localstatedir? (symlinks '()) - (tar tar)) + (archiver tar)) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -99,11 +102,14 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." (define build - (with-imported-modules '((guix build utils) - (guix build store-copy) - (gnu build install)) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build union) + (guix build store-copy) + (gnu build install))) #~(begin (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) (gnu build install) (srfi srfi-1) (srfi srfi-26) @@ -116,9 +122,17 @@ added to the pack." ;; parent directories. (match-lambda ((source '-> target) - (let ((target (string-append #$profile "/" target))) - `((directory ,(dirname source)) - (,source -> ,target)))))) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) (define directives ;; Fully-qualified symlinks. @@ -128,7 +142,7 @@ added to the pack." ;; 2014-07-28. For testing, we use the bootstrap tar, which is ;; older and doesn't support it. (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") + (zero? (system* (string-append #+archiver "/bin/tar") "cf" "/dev/null" "--files-from=/dev/null" "--sort=name"))) @@ -137,11 +151,13 @@ added to the pack." (string-append #$(if localstatedir? (file-append guix "/sbin:") "") - #$tar "/bin")) + #$archiver "/bin")) - ;; Note: there is not much to gain here with deduplication and - ;; there is the overhead of the '.links' directory, so turn it - ;; off. + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. (populate-single-profile-directory %root #:profile #$profile #:closure "profile" @@ -188,6 +204,8 @@ added to the pack." (filter-map (match-lambda (('directory directory) (string-append "." directory)) + ((source '-> _) + (string-append "." source)) (_ #f)) directives))))))))) @@ -196,13 +214,97 @@ added to the pack." build #:references-graphs `(("profile" ,profile)))) +(define* (squashfs-image name profile + #:key target + deduplicate? + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver squashfs-tools-next)) + "Return a squashfs image containing a store initialized with the closure of +PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount +points for virtual file systems (like procfs), and optional symlinks. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." + (define build + (with-imported-modules '((guix build utils) + (guix build store-copy) + (gnu build install)) + #~(begin + (use-modules (guix build utils) + (gnu build install) + (guix build store-copy) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (setenv "PATH" (string-append #$archiver "/bin")) + + ;; We need an empty file in order to have a valid file argument when + ;; we reparent the root file system. Read on for why that's + ;; necessary. + (with-output-to-file ".empty" (lambda () (display ""))) + + ;; Create the squashfs image in several steps. + ;; Add all store items. Unfortunately mksquashfs throws away all + ;; ancestor directories and only keeps the basename. We fix this + ;; in the following invocations of mksquashfs. + (apply invoke "mksquashfs" + `(,@(call-with-input-file "profile" + read-reference-graph) + ,#$output + + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) + + ;; Here we reparent the store items. For each sub-directory of + ;; the store prefix we need one invocation of "mksquashfs". + (for-each (lambda (dir) + (apply invoke "mksquashfs" + `(".empty" + ,#$output + "-root-becomes" ,dir))) + (reverse (string-tokenize (%store-directory) + (char-set-complement (char-set #\/))))) + + ;; Add symlinks and mount points. + (apply invoke "mksquashfs" + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(append-map + (match-lambda + ((source '-> target) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (string-append #$profile "/" target)))))) + '#$symlinks) + + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0"))))) + + (gexp->derivation (string-append name + (compressor-extension compressor) + ".squashfs") + build + #:references-graphs `(("profile" ,profile)))) + (define* (docker-image name profile #:key target deduplicate? (compressor (first %compressors)) localstatedir? (symlinks '()) - (tar tar)) + (archiver tar)) "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -216,11 +318,13 @@ the image." (('gnu rest ...) #t) (rest #f))) + (define defmod 'define-module) ;trick Geiser + (define config ;; (guix config) module for consumption by (guix gcrypt). (scheme-file "gcrypt-config.scm" #~(begin - (define-module (guix config) + (#$defmod (guix config) #:export (%libgcrypt)) ;; XXX: Work around <http://bugs.gnu.org/15602>. @@ -236,28 +340,25 @@ the image." guile-json)) (define build - (with-imported-modules `(,@(source-module-closure '((guix docker)) - #:select? not-config?) - (guix build store-copy) - ((guix config) => ,config)) - #~(begin - ;; Guile-JSON is required by (guix docker). - (add-to-load-path - (string-append #+json "/share/guile/site/" - (effective-version))) - - (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) - - (setenv "PATH" (string-append #$tar "/bin")) - - (build-docker-image #$output - (call-with-input-file "profile" - read-reference-graph) - #$profile - #:system (or #$target (utsname:machine (uname))) - #:symlinks '#$symlinks - #:compressor '#$(compressor-command compressor) - #:creation-time (make-time time-utc 0 1))))) + ;; Guile-JSON is required by (guix docker). + (with-extensions (list json) + (with-imported-modules `(,@(source-module-closure '((guix docker)) + #:select? not-config?) + (guix build store-copy) + ((guix config) => ,config)) + #~(begin + (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) + + (setenv "PATH" (string-append #$archiver "/bin")) + + (build-docker-image #$output + (call-with-input-file "profile" + read-reference-graph) + #$profile + #:system (or #$target (utsname:machine (uname))) + #:symlinks '#$symlinks + #:compressor '#$(compressor-command compressor) + #:creation-time (make-time time-utc 0 1)))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -266,6 +367,165 @@ the image." ;;; +;;; Compiling C programs. +;;; + +;; A C compiler. That lowers to a single program that can be passed typical C +;; compiler flags, and it makes sure the whole toolchain is available. +(define-record-type <c-compiler> + (%c-compiler toolchain guile) + c-compiler? + (toolchain c-compiler-toolchain) + (guile c-compiler-guile)) + +(define* (c-compiler #:optional inputs + #:key (guile (default-guile))) + (%c-compiler inputs guile)) + +(define (bootstrap-c-compiler) + "Return the C compiler that uses the bootstrap toolchain. This is used only +by '--bootstrap', for testing purposes." + (define bootstrap-toolchain + (list (first (assoc-ref %bootstrap-inputs "gcc")) + (first (assoc-ref %bootstrap-inputs "binutils")) + (first (assoc-ref %bootstrap-inputs "libc")))) + + (c-compiler bootstrap-toolchain + #:guile %bootstrap-guile)) + +(define-gexp-compiler (c-compiler-compiler (compiler <c-compiler>) system target) + "Lower COMPILER to a single script that does the right thing." + (define toolchain + (or (c-compiler-toolchain compiler) + (list (first (assoc-ref (standard-packages) "gcc")) + (first (assoc-ref (standard-packages) "ld-wrapper")) + (first (assoc-ref (standard-packages) "binutils")) + (first (assoc-ref (standard-packages) "libc")) + (gexp-input (first (assoc-ref (standard-packages) "libc")) + "static")))) + + (define inputs + (match (append-map package-propagated-inputs + (filter package? toolchain)) + (((labels things . _) ...) + (append toolchain things)))) + + (define search-paths + (cons $PATH + (append-map package-native-search-paths + (filter package? inputs)))) + + (define run + (with-imported-modules (source-module-closure + '((guix build utils) + (guix search-paths))) + #~(begin + (use-modules (guix build utils) (guix search-paths) + (ice-9 match)) + + (define (output-file args) + (let loop ((args args)) + (match args + (() "a.out") + (("-o" file _ ...) file) + ((head rest ...) (loop rest))))) + + (set-search-paths (map sexp->search-path-specification + '#$(map search-path-specification->sexp + search-paths)) + '#$inputs) + + (let ((output (output-file (command-line)))) + (apply invoke "gcc" (cdr (command-line))) + (invoke "strip" output))))) + + (when target + ;; TODO: Yep, we'll have to do it someday! + (leave (G_ "cross-compilation not implemented here; +please email '~a'~%") + (@ (guix config) %guix-bug-report-address))) + + (gexp->script "c-compiler" run + #:guile (c-compiler-guile compiler))) + + +;;; +;;; Wrapped package. +;;; + +(define* (wrapped-package package + #:optional (compiler (c-compiler))) + (define runner + (local-file (search-auxiliary-file "run-in-namespace.c"))) + + (define build + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build union))) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (ice-9 ftw) + (ice-9 match)) + + (define (strip-store-prefix file) + ;; Given a file name like "/gnu/store/…-foo-1.2/bin/foo", return + ;; "/bin/foo". + (let* ((len (string-length (%store-directory))) + (base (string-drop file (+ 1 len)))) + (match (string-index base #\/) + (#f base) + (index (string-drop base index))))) + + (define (build-wrapper program) + ;; Build a user-namespace wrapper for PROGRAM. + (format #t "building wrapper for '~a'...~%" program) + (copy-file #$runner "run.c") + + (substitute* "run.c" + (("@WRAPPED_PROGRAM@") program) + (("@STORE_DIRECTORY@") (%store-directory))) + + (let* ((base (strip-store-prefix program)) + (result (string-append #$output "/" base))) + (mkdir-p (dirname result)) + (invoke #$compiler "-std=gnu99" "-static" "-Os" "-g0" "-Wall" + "run.c" "-o" result) + (delete-file "run.c"))) + + (setvbuf (current-output-port) + (cond-expand (guile-2.2 'line) + (else _IOLBF))) + + ;; Link the top-level files of PACKAGE so that search paths are + ;; properly defined in PROFILE/etc/profile. + (mkdir #$output) + (for-each (lambda (file) + (unless (member file '("." ".." "bin" "sbin" "libexec")) + (let ((file* (string-append #$package "/" file))) + (symlink (relative-file-name #$output file*) + (string-append #$output "/" file))))) + (scandir #$package)) + + (for-each build-wrapper + (append (find-files #$(file-append package "/bin")) + (find-files #$(file-append package "/sbin")) + (find-files #$(file-append package "/libexec"))))))) + + (computed-file (string-append (package-full-name package "-") "R") + build)) + +(define (map-manifest-entries proc manifest) + "Apply PROC to all the entries of MANIFEST and return a new manifest." + (make-manifest + (map (lambda (entry) + (manifest-entry + (inherit entry) + (item (proc (manifest-entry-item entry))))) + (manifest-entries manifest)))) + + +;;; ;;; Command-line options. ;;; @@ -283,6 +543,7 @@ the image." (define %formats ;; Supported pack formats. `((tarball . ,self-contained-tarball) + (squashfs . ,squashfs-image) (docker . ,docker-image))) (define %options @@ -301,6 +562,9 @@ the image." (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '(#\R "relocatable") #f #f + (lambda (opt name arg result) + (alist-cons 'relocatable? #t result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -353,6 +617,8 @@ Create a bundle of PACKAGE.\n")) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " + -R, --relocatable produce relocatable executables")) + (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) @@ -397,9 +663,15 @@ Create a bundle of PACKAGE.\n")) (read/eval-package-expression exp)) (x #f))) - (define (manifest-from-args opts) - (let ((packages (filter-map maybe-package-argument opts)) - (manifest-file (assoc-ref opts 'manifest))) + (define (manifest-from-args store opts) + (let* ((transform (options->transformation opts)) + (packages (map (match-lambda + (((? package? package) output) + (list (transform store package) output)) + ((? package? package) + (list (transform store package) "out"))) + (filter-map maybe-package-argument opts))) + (manifest-file (assoc-ref opts 'manifest))) (cond ((and manifest-file (not (null? packages))) (leave (G_ "both a manifest and a package list were given~%"))) @@ -409,39 +681,49 @@ Create a bundle of PACKAGE.\n")) (else (packages->manifest packages))))) (with-error-handling - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (manifest (manifest-from-args opts)) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (tar (if bootstrap? - %bootstrap-coreutils&co - tar)) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format") - format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) - (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - + (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((dry-run? (assoc-ref opts 'dry-run?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries wrapped-package manifest) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools-next + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format") + format)))) + (localstatedir? (assoc-ref opts 'localstatedir?))) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest + #:relative-symlinks? relocatable? #:hooks (if bootstrap? '() %default-profile-hooks) @@ -456,8 +738,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? - #:tar - tar))) + #:archiver + archiver))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4f519e6f33..29829f52c8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -64,46 +64,6 @@ ;;; Profiles. ;;; -(define %user-profile-directory - (and=> (getenv "HOME") - (cut string-append <> "/.guix-profile"))) - -(define %profile-directory - (string-append %state-directory "/profiles/" - (or (and=> (or (getenv "USER") - (getenv "LOGNAME")) - (cut string-append "per-user/" <>)) - "default"))) - -(define %current-profile - ;; Call it `guix-profile', not `profile', to allow Guix profiles to - ;; coexist with Nix profiles. - (string-append %profile-directory "/guix-profile")) - -(define (canonicalize-profile profile) - "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise -return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if -'-p' was omitted." ; see <http://bugs.gnu.org/17939> - - ;; Trim trailing slashes so that the basename comparison below works as - ;; intended. - (let ((profile (string-trim-right profile #\/))) - (if (and %user-profile-directory - (string=? (canonicalize-path (dirname profile)) - (dirname %user-profile-directory)) - (string=? (basename profile) (basename %user-profile-directory))) - %current-profile - profile))) - -(define (user-friendly-profile profile) - "Return either ~/.guix-profile if that's what PROFILE refers to, directly or -indirectly, or PROFILE." - (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) profile))) - %user-profile-directory - profile)) - (define (ensure-default-profile) "Ensure the default profile symlink and directory exist and are writable." diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 64c2196e03..499de0ec45 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -25,10 +25,15 @@ #:use-module (guix config) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix profiles) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix scripts build) + #:autoload (guix self) (whole-package) + #:autoload (gnu packages ssh) (guile-ssh) + #:autoload (gnu packages tls) (gnutls) + #:use-module ((guix scripts package) #:select (build-and-use-profile)) #:use-module ((guix build utils) #:select (with-directory-excursion delete-file-recursively)) #:use-module ((guix build download) @@ -158,6 +163,12 @@ Download and deploy the latest version of Guix.\n")) ;; a makefile, and, similarly, is intended to always keep this name. "build-aux/build-self.scm") +(define %pull-version + ;; This is the version of the 'guix pull' protocol. It specifies what's + ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd + ;; place a set of compiled Guile modules in ~/.config/guix/latest. + 1) + (define* (build-from-source source #:key verbose? commit) "Return a derivation to build Guix from SOURCE, using the self-build script @@ -170,35 +181,62 @@ contained therein. Use COMMIT as the version string." (build (primitive-load script))) ;; BUILD must be a monadic procedure of at least one argument: the source ;; tree. - (build source #:verbose? verbose? #:version commit))) + ;; + ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In the + ;; future we'll fall back to a previous version of the protocol when that + ;; happens. + (build source #:verbose? verbose? #:version commit + #:pull-version %pull-version))) + +(define (whole-package-for-legacy name modules) + "Return a full-blown Guix package for MODULES, a derivation that builds Guix +modules in the old ~/.config/guix/latest style." + (whole-package name modules + + ;; In the "old style", %SELF-BUILD-FILE would simply return a + ;; derivation that builds modules. We have to infer what the + ;; dependencies of these modules were. + (list guile-json guile-git guile-bytestructures + guile-ssh gnutls))) + +(define* (derivation->manifest-entry drv + #:key url branch commit) + "Return a manifest entry for DRV, which represents Guix at COMMIT. Record +URL, BRANCH, and COMMIT as a property in the manifest entry." + (mbegin %store-monad + (what-to-build (list drv)) + (built-derivations (list drv)) + (let ((out (derivation->output-path drv))) + (return (manifest-entry + (name "guix") + (version (string-take commit 7)) + (item (if (file-exists? (string-append out "/bin/guix")) + drv + (whole-package-for-legacy (string-append name "-" + version) + drv))) + (properties + `((source (repository + (version 0) + (url ,url) + (branch ,branch) + (commit ,commit)))))))))) (define* (build-and-install source config-dir - #:key verbose? commit) + #:key verbose? url branch commit) "Build the tool from SOURCE, and install it in CONFIG-DIR." - (mlet* %store-monad ((source (build-from-source source - #:commit commit - #:verbose? verbose?)) - (source-dir -> (derivation->output-path source)) - (to-do? (what-to-build (list source))) - (built? (built-derivations (list source)))) - ;; Always update the 'latest' symlink, regardless of whether SOURCE was - ;; already built or not. - (if built? - (mlet* %store-monad - ((latest -> (string-append config-dir "/latest")) - (done (indirect-root-added latest))) - (if (and (file-exists? latest) - (string=? (readlink latest) source-dir)) - (begin - (display (G_ "Guix already up to date\n")) - (return #t)) - (begin - (switch-symlinks latest source-dir) - (format #t - (G_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - (return #t)))) - (leave (G_ "failed to update Guix, check the build log~%"))))) + (define update-profile + (store-lift build-and-use-profile)) + + (mlet* %store-monad ((drv (build-from-source source + #:commit commit + #:verbose? verbose?)) + (entry (derivation->manifest-entry drv + #:url url + #:branch branch + #:commit commit))) + (update-profile (string-append config-dir "/current") + (manifest (list entry))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -279,6 +317,11 @@ certificates~%")) (canonical-package guile-2.2))))) (run-with-store store (build-and-install checkout (config-directory) + #:url url + #:branch (match ref + (('branch . branch) + branch) + (_ #f)) #:commit commit #:verbose? (assoc-ref opts 'verbose?)))))))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index af501eb8f7..14be8ff8cf 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -393,9 +393,11 @@ it atomically, and then run OS's activation script." "~Y-~m-~d ~H:~M"))) (define* (profile-boot-parameters #:optional (profile %system-profile) - (numbers (generation-numbers profile))) - "Return a list of 'boot-parameters' for the generations of PROFILE specified by -NUMBERS, which is a list of generation numbers." + (numbers + (reverse (generation-numbers profile)))) + "Return a list of 'boot-parameters' for the generations of PROFILE specified +by NUMBERS, which is a list of generation numbers. The list is ordered from +the most recent to the oldest profiles." (define (system->boot-parameters system number time) (unless-file-not-found (let* ((params (read-boot-parameters-file system)) @@ -590,17 +592,17 @@ any, are available. Raise an error if they're not." (define labeled (filter (lambda (fs) - (eq? (file-system-title fs) 'label)) + (file-system-label? (file-system-device fs))) relevant)) (define literal (filter (lambda (fs) - (eq? (file-system-title fs) 'device)) + (string? (file-system-device fs))) relevant)) (define uuid (filter (lambda (fs) - (eq? (file-system-title fs) 'uuid)) + (uuid? (file-system-device fs))) relevant)) (define fail? #f) @@ -628,15 +630,15 @@ any, are available. Raise an error if they're not." (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system -label, you need to add @code{(title 'label)} to your @code{file-system} -definition.") - device))))))) +label, write @code{(file-system-label ~s)} in your @code{device} field.") + device device))))))) literal) (for-each (lambda (fs) - (unless (find-partition-by-label (file-system-device fs)) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) - (file-system-device fs)))) + (let ((label (file-system-label->string + (file-system-device fs)))) + (unless (find-partition-by-label label) + (error (G_ "~a: error: file system with label '~a' not found~%") + (file-system-location* fs) label)))) labeled) (for-each (lambda (fs) (unless (find-partition-by-uuid (file-system-device fs)) @@ -677,10 +679,13 @@ available in the initrd. Note that mapped devices are responsible for checking this by themselves in their 'check' procedure." (define (file-system-/dev fs) (let ((device (file-system-device fs))) - (match (file-system-title fs) - ('device device) - ('uuid (find-partition-by-uuid device)) - ('label (find-partition-by-label device))))) + (match device + ((? string?) + device) + ((? uuid?) + (find-partition-by-uuid device)) + ((? file-system-label?) + (find-partition-by-label (file-system-label->string device)))))) (define file-systems (filter file-system-needed-for-boot? @@ -735,7 +740,7 @@ checking this by themselves in their 'check' procedure." ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for ;; a discussion. (define latest - (string-append (config-directory) "/latest")) + (string-append (config-directory) "/current")) (unless (file-exists? latest) (warning (G_ "~a not found: 'guix pull' was never run~%") latest) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index 7229c60a02..955cdd1e95 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,10 +60,8 @@ provided TYPE has a default value." (define (service-type-shepherd-names type) "Return the default names of Shepherd services created for TYPE." - (match (map shepherd-service-provision - (service-type-default-shepherd-services type)) - (((names . _) ...) - names))) + (append-map shepherd-service-provision + (service-type-default-shepherd-services type))) (define* (service-type->recutils type port #:optional (width (%text-width)) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 5c934abaef..d7c2fbea10 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -208,10 +208,10 @@ unavailable)~%")) 0 queue))) (newline) (unless (null? missing) - (let ((missing (length missing))) - (match (queued-subset queue missing) - (#f #f) - ((= length queued) + (match (queued-subset queue missing) + (#f #f) + ((= length queued) + (let ((missing (length missing))) (format #t (G_ " ~,1f% (~h out of ~h) of the missing items \ are queued~%") (* 100. (/ queued missing)) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 4bf0e44389..002e6342bb 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +38,8 @@ string-tokenize* evaluate-search-paths environment-variable-definition - search-path-definition)) + search-path-definition + set-search-paths)) ;;; Commentary: ;;; @@ -196,4 +197,14 @@ prefix/suffix." #:kind kind #:separator separator)))) +(define* (set-search-paths search-paths directories + #:key (setenv setenv)) + "Set the search path environment variables specified by SEARCH-PATHS for the +given directories." + (for-each (match-lambda + ((spec . value) + (setenv (search-path-specification-variable spec) + value))) + (evaluate-search-paths search-paths directories))) + ;;; search-paths.scm ends here diff --git a/guix/self.scm b/guix/self.scm index 6220efb397..e71e086cdc 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -34,6 +34,7 @@ #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:export (make-config.scm + whole-package ;for internal use in 'guix pull' compiled-guix guix-derivation reload-guix)) @@ -82,6 +83,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) @@ -92,6 +94,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("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". (_ #f)))) ;no such package @@ -167,7 +170,8 @@ must be present in the search path." (source (imported-files (string-append name "-source") (append module-files extra-files)))) (node name modules source dependencies - (compiled-modules name source modules + (compiled-modules name source + (map car module-files) (map node-source dependencies) (map node-compiled dependencies) #:extensions extensions @@ -189,7 +193,229 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (file-name->module-name (string-drop file prefix))) (scheme-files (string-append directory "/" sub-directory))))) +(define* (sub-directory item sub-directory) + "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like +object." + (match item + ((? string?) + ;; This is the optimal case: we return a new "source". Thus, a + ;; derivation that depends on this sub-directory does not depend on ITEM + ;; itself. + (local-file (string-append item "/" sub-directory) + #:recursive? #t)) + ;; TODO: Add 'local-file?' case. + (_ + ;; In this case, anything that refers to the result also depends on ITEM, + ;; which isn't great. + (file-append item "/" sub-directory)))) + +(define* (locale-data source domain + #:optional (directory domain)) + "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to +DOMAIN, a gettext domain." + (define gettext + (module-ref (resolve-interface '(gnu packages gettext)) + 'gettext-minimal)) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-26) + (ice-9 match) (ice-9 ftw)) + + (define po-directory + #+(sub-directory source (string-append "po/" directory))) + + (define (compile language) + (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" + #$domain ".mo"))) + (mkdir-p (dirname gmo)) + (invoke #+(file-append gettext "/bin/msgfmt") + "-c" "--statistics" "--verbose" + "-o" gmo + (string-append po-directory "/" language ".po")))) + + (define (linguas) + ;; Return the list of languages. Note: don't read 'LINGUAS' + ;; because it contains things like 'en@boldquot' that do not have + ;; a corresponding .po file. + (map (cut basename <> ".po") + (scandir po-directory + (cut string-suffix? ".po" <>)))) + + (for-each compile (linguas))))) + + (computed-file (string-append "guix-locale-" domain) + build)) + +(define (info-manual source) + "Return the Info manual built from SOURCE." + (define texinfo + (module-ref (resolve-interface '(gnu packages texinfo)) + 'texinfo)) + + (define graphviz + (module-ref (resolve-interface '(gnu packages graphviz)) + 'graphviz)) + + (define documentation + (sub-directory source "doc")) + + (define examples + (sub-directory source "gnu/system/examples")) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (mkdir #$output) + + ;; Create 'version.texi'. + ;; XXX: Can we use a more meaningful version string yet one that + ;; doesn't change at each commit? + (call-with-output-file "version.texi" + (lambda (port) + (let ((version "0.0-git)")) + (format port " +@set UPDATED 1 January 1970 +@set UPDATED-MONTH January 1970 +@set EDITION ~a +@set VERSION ~a\n" version version)))) + + ;; Copy configuration templates that the manual includes. + (for-each (lambda (template) + (copy-file template + (string-append + "os-config-" + (basename template ".tmpl") + ".texi"))) + (find-files #$examples "\\.tmpl$")) + + ;; Build graphs. + (mkdir-p (string-append #$output "/images")) + (for-each (lambda (dot-file) + (invoke #+(file-append graphviz "/bin/dot") + "-Tpng" "-Gratio=.9" "-Gnodesep=.005" + "-Granksep=.00005" "-Nfontsize=9" + "-Nheight=.1" "-Nwidth=.1" + "-o" (string-append #$output "/images/" + (basename dot-file ".dot") + ".png") + dot-file)) + (find-files (string-append #$documentation "/images") + "\\.dot$")) + + ;; Copy other PNGs. + (for-each (lambda (png-file) + (install-file png-file + (string-append #$output "/images"))) + (find-files (string-append #$documentation "/images") + "\\.png$")) + + ;; Finally build the manual. Copy it the Texinfo files to $PWD and + ;; add a symlink to the 'images' directory so that 'makeinfo' can + ;; see those images and produce image references in the Info output. + (copy-recursively #$documentation "." + #:log (%make-void-port "w")) + (delete-file-recursively "images") + (symlink (string-append #$output "/images") "images") + + (for-each (lambda (texi) + (unless (string=? "guix.texi" texi) + ;; Create 'version-LL.texi'. + (let* ((base (basename texi ".texi")) + (dot (string-index base #\.)) + (tag (string-drop base (+ 1 dot)))) + (symlink "version.texi" + (string-append "version-" tag ".texi")))) + + (invoke #+(file-append texinfo "/bin/makeinfo") + texi "-I" #$documentation + "-I" "." + "-o" (string-append #$output "/" + (basename texi ".texi") + ".info"))) + (cons "guix.texi" + (find-files "." "^guix\\.[a-z]{2}\\.texi$")))))) + + (computed-file "guix-manual" build)) + +(define* (guix-command modules #:key source (dependencies '()) + (guile-version (effective-version))) + "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its +load path." + (program-file "guix-command" + #~(begin + (set! %load-path + (append '#$(map (lambda (package) + (file-append package + "/share/guile/site/" + guile-version)) + dependencies) + %load-path)) + + (set! %load-compiled-path + (append '#$(map (lambda (package) + (file-append package "/lib/guile/" + guile-version + "/site-ccache")) + dependencies) + %load-compiled-path)) + + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$modules %load-compiled-path)) + + (let ((guix-main (module-ref (resolve-interface '(guix ui)) + 'guix-main))) + #$(if source + #~(begin + (bindtextdomain "guix" + #$(locale-data source "guix")) + (bindtextdomain "guix-packages" + #$(locale-data source + "guix-packages" + "packages"))) + #t) + + ;; XXX: It would be more convenient to change it to: + ;; (exit (apply guix-main (command-line))) + (apply guix-main (command-line)))))) + +(define* (whole-package name modules dependencies + #:key + (guile-version (effective-version)) + info + (command (guix-command modules + #:dependencies dependencies + #: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." + ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. + (computed-file name + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")) + (symlink #$command + (string-append #$output "/bin/guix")) + + (let ((modules (string-append #$output + "/share/guile/site/" + (effective-version))) + (info #$info)) + (mkdir-p (dirname modules)) + (symlink #$modules modules) + (when info + (symlink #$info + (string-append #$output + "/share/info")))))))) + (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)) @@ -215,12 +441,16 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." "guile-git" "guile2.0-git")) + (define guile-sqlite3 + (package-for-guile guile-version + "guile-sqlite3" + "guile2.0-sqlite3")) (define dependencies (match (append-map (lambda (package) (cons (list "x" package) - (package-transitive-inputs package))) - (list guile-git guile-json guile-ssh)) + (package-transitive-propagated-inputs package))) + (list guile-git guile-json guile-ssh guile-sqlite3)) (((labels packages _ ...) ...) packages))) @@ -248,25 +478,37 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (specification->package "libgcrypt")))) + ;; (guix man-db) is needed at build-time by (guix profiles) + ;; but we don't need to compile it; not compiling it allows + ;; us to avoid an extra dependency on guile-gdbm-ffi. + #:extra-files + `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))) + #:guile-for-build guile-for-build)) (define *extra-modules* (scheme-node "guix-extra" (filter-map (match-lambda (('guix 'scripts _ ..1) #f) + (('guix 'man-db) #f) (name name)) (scheme-modules* source "guix")) (list *core-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) - (define *package-modules* - (scheme-node "guix-packages" + (define *core-package-modules* + (scheme-node "guix-packages-base" `((gnu packages) - ,@(scheme-modules* source "gnu/packages")) + (gnu packages base)) (list *core-modules* *extra-modules*) #:extensions dependencies - #:extra-files ;all the non-Scheme files + + ;; Add all the non-Scheme files here. We must do it here so + ;; that 'search-patches' & co. can find them. Ideally we'd + ;; keep them next to the .scm files that use them but it's + ;; difficult to do (XXX). + #:extra-files (file-imports source "gnu/packages" (lambda (file stat) (and (eq? 'regular (stat:type stat)) @@ -276,23 +518,37 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (not (string-suffix? "~" file))))) #:guile-for-build guile-for-build)) + (define *package-modules* + (scheme-node "guix-packages" + (scheme-modules* source "gnu/packages") + (list *core-modules* *extra-modules* *core-package-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *system-modules* (scheme-node "guix-system" `((gnu system) (gnu services) ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) - (list *package-modules* *extra-modules* *core-modules*) + (list *core-package-modules* *package-modules* + *extra-modules* *core-modules*) #:extensions dependencies #:extra-files - (file-imports source "gnu/system/examples" (const #t)) + (append (file-imports source "gnu/system/examples" + (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))) #:guile-for-build guile-for-build)) (define *cli-modules* (scheme-node "guix-cli" (scheme-modules* source "/guix/scripts") - (list *core-modules* *extra-modules* *package-modules* + (list *core-modules* *extra-modules* + *core-package-modules* *package-modules* *system-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) @@ -318,31 +574,52 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." %guix-home-page-url))) #:guile-for-build guile-for-build)) - (directory-union name - (append-map (lambda (node) - (list (node-source node) - (node-compiled node))) - - ;; Note: *CONFIG* comes first so that it - ;; overrides the (guix config) module that - ;; comes with *CORE-MODULES*. - (list *config* - *cli-modules* - *system-modules* - *package-modules* - *extra-modules* - *core-modules*)) - - ;; Silently choose the first entry upon collision so that - ;; we choose *CONFIG*. - #:resolve-collision 'first - - ;; When we do (add-to-store "utils.scm"), "utils.scm" must - ;; be a regular file, not a symlink. Thus, arrange so that - ;; regular files appear as regular files in the final - ;; output. - #:copy? #t - #:quiet? #t)) + (define built-modules + (directory-union (string-append name "-modules") + (append-map (lambda (node) + (list (node-source node) + (node-compiled node))) + + ;; Note: *CONFIG* comes first so that it + ;; overrides the (guix config) module that + ;; comes with *CORE-MODULES*. + (list *config* + *cli-modules* + *system-modules* + *package-modules* + *core-package-modules* + *extra-modules* + *core-modules*)) + + ;; Silently choose the first entry upon collision so that + ;; we choose *CONFIG*. + #:resolve-collision 'first + + ;; When we do (add-to-store "utils.scm"), "utils.scm" must + ;; be a regular file, not a symlink. Thus, arrange so that + ;; regular files appear as regular files in the final + ;; output. + #:copy? #t + #:quiet? #t)) + + ;; Version 0 of 'guix pull' meant we'd just return Scheme modules. + ;; Version 1 is when we return the full package. + (cond ((= 1 pull-version) + ;; The whole package, with a standard file hierarchy. + (let ((command (guix-command built-modules + #:source source + #:dependencies dependencies + #:guile-version guile-version))) + (whole-package name built-modules dependencies + #:command command + #:info (info-manual source) + #:guile-version guile-version))) + ((= 0 pull-version) + ;; Legacy 'guix pull': just return the compiled modules. + built-modules) + (else + ;; Unsupported 'guix pull' version. + #f))) ;;; @@ -451,6 +728,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (define (imported-files name files) ;; This is a non-monadic, simplified version of 'imported-files' from (guix ;; gexp). + (define same-target? + (match-lambda* + (((file1 . _) (file2 . _)) + (string=? file1 file2)))) + (define build (with-imported-modules (source-module-closure '((guix build utils))) @@ -467,14 +749,15 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." ;; symlinks, as this makes a difference for ;; 'add-to-store'. (copy-file store-path final-path))) - '#$files)))) + '#$(delete-duplicates files same-target?))))) ;; We're just copying files around, no need to substitute or offload it. (computed-file name build #:options '(#:local-build? #t - #:substitutable? #f))) + #:substitutable? #f + #:env-vars (("COLUMNS" . "200"))))) -(define* (compiled-modules name module-tree modules +(define* (compiled-modules name module-tree module-files #:optional (dependencies '()) (dependencies-compiled '()) @@ -482,6 +765,9 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (extensions '()) ;full-blown Guile packages parallel? guile-for-build) + "Build all the MODULE-FILES from MODULE-TREE. MODULE-FILES must be a list +like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory +containing MODULE-FILES and possibly other files as well." ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix ;; gexp). (define build @@ -512,16 +798,13 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (* 100. (/ completed total)) total) (force-output)) - (define (process-directory directory output) - (let ((files (find-files directory "\\.scm$")) - (prefix (+ 1 (string-length directory)))) - ;; Hide compilation warnings. - (parameterize ((current-warning-port (%make-void-port "w"))) - (compile-files directory #$output - (map (cut string-drop <> prefix) files) - #:workers (parallel-job-count) - #:report-load report-load - #:report-compilation report-compilation)))) + (define (process-directory directory files output) + ;; Hide compilation warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-files directory #$output files + #:workers (parallel-job-count) + #:report-load report-load + #:report-compilation report-compilation))) (setvbuf (current-output-port) _IONBF) (setvbuf (current-error-port) _IONBF) @@ -549,7 +832,7 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (mkdir #$output) (chdir #+module-tree) - (process-directory "." #$output) + (process-directory "." '#+module-files #$output) (newline)))) (computed-file name build @@ -558,7 +841,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." `(#:local-build? #f ;allow substitutes ;; Don't annoy people about _IONBF deprecation. - #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) + ;; Initialize 'terminal-width' in (system repl debug) + ;; to a large-enough value to make backtrace more + ;; verbose. + #:env-vars (("GUILE_WARN_DEPRECATED" . "no") + ("COLUMNS" . "200"))))) ;;; @@ -586,9 +873,12 @@ running Guile." 'guile-2.0)))) (define* (guix-derivation source version - #:optional (guile-version (effective-version))) + #:optional (guile-version (effective-version)) + #:key (pull-version 0)) "Return, as a monadic value, the derivation to build the Guix from SOURCE -for GUILE-VERSION. Use VERSION as the version string." +for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies +the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value +is not supported." (define (shorten version) (if (and (string-every char-set:hex-digit version) (> (string-length version) 9)) @@ -600,11 +890,15 @@ for GUILE-VERSION. Use VERSION as the version string." (mbegin %store-monad (set-guile-for-build guile) - (lower-object (compiled-guix source - #:version version - #:name (string-append "guix-" - (shorten version)) - #:guile-version (match guile-version - ("2.2.2" "2.2") - (version version)) - #:guile-for-build guile)))) + (let ((guix (compiled-guix source + #:version version + #:name (string-append "guix-" + (shorten version)) + #:pull-version pull-version + #:guile-version (match guile-version + ("2.2.2" "2.2") + (version version)) + #:guile-for-build guile))) + (if guix + (lower-object guix) + (return #f))))) diff --git a/guix/store/database.scm b/guix/store/database.scm new file mode 100644 index 0000000000..3623c0e7a0 --- /dev/null +++ b/guix/store/database.scm @@ -0,0 +1,234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> +;;; Copyright © 2018 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 store database) + #:use-module (sqlite3) + #:use-module (guix config) + #:use-module (guix serialization) + #:use-module (guix store deduplication) + #:use-module (guix base16) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:export (sqlite-register + register-path + reset-timestamps)) + +;;; Code for working with the store database directly. + + +(define-syntax-rule (with-database file db exp ...) + "Open DB from FILE and close it when the dynamic extent of EXP... is left." + (let ((db (sqlite-open file))) + (dynamic-wind noop + (lambda () + exp ...) + (lambda () + (sqlite-close db))))) + +(define (last-insert-row-id db) + ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'. + ;; Work around that. + (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();" + #:cache? #t)) + (result (sqlite-fold cons '() stmt))) + (sqlite-finalize stmt) + (match result + ((#(id)) id) + (_ #f)))) + +(define path-id-sql + "SELECT id FROM ValidPaths WHERE path = :path") + +(define* (path-id db path) + "If PATH exists in the 'ValidPaths' table, return its numerical +identifier. Otherwise, return #f." + (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:path path) + (let ((result (sqlite-fold cons '() stmt))) + (sqlite-finalize stmt) + (match result + ((#(id) . _) id) + (_ #f))))) + +(define update-sql + "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver = +:deriver, narSize = :size WHERE id = :id") + +(define insert-sql + "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize) +VALUES (:path, :hash, :time, :deriver, :size)") + +(define* (update-or-insert db #:key path deriver hash nar-size time) + "The classic update-if-exists and insert-if-doesn't feature that sqlite +doesn't exactly have... they've got something close, but it involves deleting +and re-inserting instead of updating, which causes problems with foreign keys, +of course. Returns the row id of the row that was modified or inserted." + (let ((id (path-id db path))) + (if id + (let ((stmt (sqlite-prepare db update-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:id id + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt) + (sqlite-finalize stmt) + (last-insert-row-id db)) + (let ((stmt (sqlite-prepare db insert-sql #:cache? #t))) + (sqlite-bind-arguments stmt + #:path path #:deriver deriver + #:hash hash #:size nar-size #:time time) + (sqlite-fold cons '() stmt) ;execute it + (sqlite-finalize stmt) + (last-insert-row-id db))))) + +(define add-reference-sql + "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id +FROM ValidPaths WHERE path = :reference") + +(define (add-references db referrer references) + "REFERRER is the id of the referring store item, REFERENCES is a list +containing store items being referred to. Note that all of the store items in +REFERENCES must already be registered." + (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t))) + (for-each (lambda (reference) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt #:referrer referrer + #:reference reference) + (sqlite-fold cons '() stmt) ;execute it + (sqlite-finalize stmt) + (last-insert-row-id db)) + references))) + +;; XXX figure out caching of statement and database objects... later +(define* (sqlite-register #:key db-file path (references '()) + deriver hash nar-size) + "Registers this stuff in a database specified by DB-FILE. PATH is the string +path of some store item, REFERENCES is a list of string paths which the store +item PATH refers to (they need to be already registered!), DERIVER is a string +path of the derivation that created the store item PATH, HASH is the +base16-encoded sha256 hash of the store item denoted by PATH (prefixed with +\"sha256:\") after being converted to nar form, and nar-size is the size in +bytes of the store item denoted by PATH after being converted to nar form." + (with-database db-file db + (let ((id (update-or-insert db #:path path + #:deriver deriver + #:hash hash + #:nar-size nar-size + #:time (time-second (current-time time-utc))))) + (add-references db id references)))) + + +;;; +;;; High-level interface. +;;; + +;; TODO: Factorize with that in (gnu build install). +(define (reset-timestamps file) + "Reset the modification time on FILE and on all the files it contains, if +it's a directory." + (let loop ((file file) + (type (stat:type (lstat file)))) + (case type + ((directory) + (utime file 0 0 0 0) + (let ((parent file)) + (for-each (match-lambda + (("." . _) #f) + ((".." . _) #f) + ((file . properties) + (let ((file (string-append parent "/" file))) + (loop file + (match (assoc-ref properties 'type) + ((or 'unknown #f) + (stat:type (lstat file))) + (type type)))))) + (scandir* parent)))) + ((symlink) + ;; FIXME: Implement bindings for 'futime' to reset the timestamps on + ;; symlinks. + #f) + (else + (utime file 0 0 0 0))))) + +;; TODO: make this canonicalize store items that are registered. This involves +;; setting permissions and timestamps, I think. Also, run a "deduplication +;; pass", whatever that involves. Also, handle databases not existing yet +;; (what should the default behavior be? Figuring out how the C++ stuff +;; currently does it sounds like a lot of grepping for global +;; variables...). Also, return #t on success like the documentation says we +;; should. + +(define* (register-path path + #:key (references '()) deriver prefix + state-directory (deduplicate? #t)) + ;; Priority for options: first what is given, then environment variables, + ;; then defaults. %state-directory, %store-directory, and + ;; %store-database-directory already handle the "environment variables / + ;; defaults" question, so we only need to choose between what is given and + ;; those. + "Register PATH as a valid store file, with REFERENCES as its list of +references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is +given, it must be the name of the directory containing the new store to +initialize; if STATE-DIRECTORY is given, it must be a string containing the +absolute file name to the state directory of the store being initialized. +Return #t on success. + +Use with care as it directly modifies the store! This is primarily meant to +be used internally by the daemon's build hook." + (let* ((db-dir (cond + (state-directory + (string-append state-directory "/db")) + (prefix + ;; If prefix is specified, the value of NIX_STATE_DIR + ;; (which affects %state-directory) isn't supposed to + ;; affect db-dir, only the compile-time-customized + ;; default should. + (string-append prefix %localstatedir "/guix/db")) + (else + %store-database-directory))) + (store-dir (if prefix + ;; same situation as above + (string-append prefix %storedir) + %store-directory)) + (to-register (if prefix + (string-append %storedir "/" (basename path)) + ;; note: we assume here that if path is, for + ;; example, /foo/bar/gnu/store/thing.txt and prefix + ;; isn't given, then an environment variable has + ;; been used to change the store directory to + ;; /foo/bar/gnu/store, since otherwise real-path + ;; would end up being /gnu/store/thing.txt, which is + ;; probably not the right file in this case. + path)) + (real-path (string-append store-dir "/" (basename path)))) + (let-values (((hash nar-size) + (nar-sha256 real-path))) + (reset-timestamps real-path) + (sqlite-register + #:db-file (string-append db-dir "/db.sqlite") + #:path to-register + #:references references + #:deriver deriver + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size) + + (when deduplicate? + (deduplicate real-path hash #:store store-dir))))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm new file mode 100644 index 0000000000..4b4ac01f64 --- /dev/null +++ b/guix/store/deduplication.scm @@ -0,0 +1,148 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org> +;;; Copyright © 2018 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/>. + +;;; This houses stuff we do to files when they arrive at the store - resetting +;;; timestamps, deduplicating, etc. + +(define-module (guix store deduplication) + #:use-module (guix hash) + #:use-module (guix build utils) + #:use-module (guix base16) + #:use-module (srfi srfi-11) + #:use-module (rnrs io ports) + #:use-module (ice-9 ftw) + #:use-module (guix serialization) + #:export (nar-sha256 + deduplicate)) + +;; Would it be better to just make WRITE-FILE give size as well? I question +;; the general utility of this approach. +(define (counting-wrapper-port output-port) + "Some custom ports don't implement GET-POSITION at all. But if we want to +figure out how many bytes are being written, we will want to use that. So this +makes a wrapper around a port which implements GET-POSITION." + (let ((byte-count 0)) + (make-custom-binary-output-port "counting-wrapper" + (lambda (bytes offset count) + (set! byte-count + (+ byte-count count)) + (put-bytevector output-port bytes + offset count) + count) + (lambda () + byte-count) + #f + (lambda () + (close-port output-port))))) + +(define (nar-sha256 file) + "Gives the sha256 hash of a file and the size of the file in nar form." + (let-values (((port get-hash) (open-sha256-port))) + (let ((wrapper (counting-wrapper-port port))) + (write-file file wrapper) + (force-output wrapper) + (force-output port) + (let ((hash (get-hash)) + (size (port-position wrapper))) + (close-port wrapper) + (values hash size))))) + +(define (tempname-in directory) + "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be +unused by the time you create anything with that name, but a good shot." + (let ((const-part (string-append directory "/.tmp-link-" + (number->string (getpid))))) + (let try ((guess-part + (number->string (random most-positive-fixnum) 16))) + (if (file-exists? (string-append const-part "-" guess-part)) + (try (number->string (random most-positive-fixnum) 16)) + (string-append const-part "-" guess-part))))) + +(define* (get-temp-link target #:optional (link-prefix (dirname target))) + "Like mkstemp!, but instead of creating a new file and giving you the name, +it creates a new hardlink to TARGET and gives you the name. Since +cross-filesystem hardlinks don't work, the temp link must be created on the +same filesystem - where in that filesystem it is can be controlled by +LINK-PREFIX." + (let try ((tempname (tempname-in link-prefix))) + (catch 'system-error + (lambda () + (link target tempname) + tempname) + (lambda (args) + (if (= (system-error-errno args) EEXIST) + (try (tempname-in link-prefix)) + (throw 'system-error args)))))) + +;; There are 3 main kinds of errors we can get from hardlinking: "Too many +;; things link to this" (EMLINK), "this link already exists" (EEXIST), and +;; "can't fit more stuff in this directory" (ENOSPC). + +(define (replace-with-link target to-replace) + "Atomically replace the file TO-REPLACE with a link to TARGET. Note: TARGET +and TO-REPLACE must be on the same file system." + (let ((temp-link (get-temp-link target (dirname to-replace)))) + (rename-file temp-link to-replace))) + +(define-syntax-rule (false-if-system-error (errors ...) exp ...) + "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and +return #f if any of the system error codes in the given list are thrown." + (catch 'system-error + (lambda () + exp ...) + (lambda args + (if (member (system-error-errno args) (list errors ...)) + #f + (apply throw args))))) + +(define* (deduplicate path hash #:key (store %store-directory)) + "Check if a store item with sha256 hash HASH already exists. If so, +replace PATH with a hardlink to the already-existing one. If not, register +PATH so that future duplicates can hardlink to it. PATH is assumed to be +under STORE." + (let* ((links-directory (string-append store "/.links")) + (link-file (string-append links-directory "/" + (bytevector->base16-string hash)))) + (mkdir-p links-directory) + (if (file-is-directory? path) + ;; Can't hardlink directories, so hardlink their atoms. + (for-each (lambda (file) + (unless (member file '("." "..")) + (deduplicate file (nar-sha256 file) + #:store store))) + (scandir path)) + (if (file-exists? link-file) + (false-if-system-error (EMLINK) + (replace-with-link link-file path)) + (catch 'system-error + (lambda () + (link path link-file)) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EEXIST) + ;; Someone else put an entry for PATH in + ;; LINKS-DIRECTORY before we could. Let's use it. + (false-if-system-error (EMLINK) + (replace-with-link path link-file))) + ((= errno ENOSPC) + ;; There's not enough room in the directory index for + ;; more entries in .links, but that's fine: we can + ;; just stop. + #f) + (else (apply throw args)))))))))) diff --git a/guix/ui.scm b/guix/ui.scm index 536c36e3fe..99f66b0fdc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014 Cyrill Schenkel <cyrill.schenkel@gmail.com> @@ -41,6 +41,13 @@ #:use-module ((guix licenses) #:select (license? license-name)) #:use-module ((guix build syscalls) #:select (free-disk-space terminal-columns)) + #:use-module ((guix build utils) + ;; XXX: All we need are the bindings related to + ;; '&invoke-error'. However, to work around the bug described + ;; in 5d669883ecc104403c5d3ba7d172e9c02234577c, #:hide + ;; unwanted bindings instead of #:select'ing the needed + ;; bindings. + #:hide (package-name->name+version)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -76,6 +83,7 @@ show-manifest-transaction call-with-error-handling with-error-handling + with-unbound-variable-handling leave-on-EPIPE read/eval read/eval-package-expression @@ -158,7 +166,7 @@ messages." ((proc message (variable) _ ...) ;; We can always omit PROC because when it's useful (i.e., different from ;; "module-lookup"), it gets displayed before. - (format port (G_ "~a: unbound variable") variable)) + (format port (G_ "error: ~a: unbound variable") variable)) (_ (default-printer)))) @@ -173,9 +181,9 @@ messages." modules) module)) -(define* (load* file user-module - #:key (on-error 'nothing-special)) - "Load the user provided Scheme source code FILE." +(define (last-frame-with-source stack) + "Walk stack upwards and return the last frame that has source location +information, or #f if it could not be found." (define (frame-with-source frame) ;; Walk from FRAME upwards until source location information is found. (let loop ((frame frame) @@ -186,6 +194,15 @@ messages." frame (loop (frame-previous frame) frame))))) + (let* ((depth (stack-length stack)) + (last (and (> depth 0) (stack-ref stack 0)))) + (frame-with-source (if (> depth 1) + (stack-ref stack 1) ;skip the 'throw' frame + last)))) + +(define* (load* file user-module + #:key (on-error 'nothing-special)) + "Load the user provided Scheme source code FILE." (define (error-string frame args) (call-with-output-string (lambda (port) @@ -238,12 +255,7 @@ messages." ;; Capture the stack up to this procedure call, excluded, and pass ;; the faulty stack frame to 'report-load-error'. (let* ((stack (make-stack #t handle-error tag)) - (depth (stack-length stack)) - (last (and (> depth 0) (stack-ref stack 0))) - (frame (frame-with-source - (if (> depth 1) - (stack-ref stack 1) ;skip the 'throw' frame - last)))) + (frame (last-frame-with-source stack))) (report-load-error file args frame) @@ -305,6 +317,21 @@ PORT." (- (terminal-columns) 5)))) (texi->plain-text message)))) +(define* (report-unbound-variable-error args #:key frame) + "Return the given unbound-variable error, where ARGS is the list of 'throw' +arguments." + (match args + ((key . args) + (print-exception (current-error-port) frame key args))) + (match args + (('unbound-variable proc message (variable) _ ...) + (match (known-variable-definition variable) + (#f + (display-hint (G_ "Did you forget a @code{use-modules} form?"))) + ((? module? module) + (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?") + (module-name module)))))))) + (define* (report-load-error file args #:optional frame) "Report the failure to load FILE, a user-provided Scheme file. ARGS is the list of arguments received by the 'throw' handler." @@ -325,16 +352,8 @@ ARGS is the list of arguments received by the 'throw' handler." (let ((loc (source-properties->location properties))) (format (current-error-port) (G_ "~a: error: ~a~%") (location->string loc) message))) - (('unbound-variable proc message (variable) _ ...) - (match args - ((key . args) - (print-exception (current-error-port) frame key args))) - (match (known-variable-definition variable) - (#f - (display-hint (G_ "Did you forget a @code{use-modules} form?"))) - (module - (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?") - (module-name module)))))) + (('unbound-variable _ ...) + (report-unbound-variable-error args #:frame frame)) (('srfi-34 obj) (if (message-condition? obj) (if (error-location? obj) @@ -375,6 +394,27 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (warning (G_ "failed to load '~a':~%") file) (apply display-error #f (current-error-port) args)))) +(define (call-with-unbound-variable-handling thunk) + (define tag + (make-prompt-tag "user-code")) + + (catch 'unbound-variable + (lambda () + (call-with-prompt tag + thunk + (const #f))) + (const #t) + (rec (handle-error . args) + (let* ((stack (make-stack #t handle-error tag)) + (frame (and stack (last-frame-with-source stack)))) + (report-unbound-variable-error args #:frame frame) + (exit 1))))) + +(define-syntax-rule (with-unbound-variable-handling exp ...) + "Capture 'unbound-variable' exceptions in the dynamic extent of EXP... and +report them in a user-friendly way." + (call-with-unbound-variable-handling (lambda () exp ...))) + (define (install-locale) "Install the current locale settings." (catch 'system-error @@ -637,6 +677,16 @@ or remove one of them from the profile.") directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) + ((invoke-error? c) + (leave (G_ "program exited\ +~@[ with non-zero exit status ~a~]\ +~@[ terminated by signal ~a~]\ +~@[ stopped by signal ~a~]: ~s~%") + (invoke-error-exit-status c) + (invoke-error-term-signal c) + (invoke-error-stop-signal c) + (cons (invoke-error-program c) + (invoke-error-arguments c)))) ((and (error-location? c) (message-condition? c)) (format (current-error-port) (G_ "~a: error: ~a~%") diff --git a/guix/utils.scm b/guix/utils.scm index 92e45de616..e9efea5866 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -84,6 +84,7 @@ version-major+minor version-major guile-version>? + version-prefix? string-replace-substring arguments-from-environment-variable file-extension @@ -521,6 +522,27 @@ minor version numbers from version-string." (micro-version)) str)) +(define version-prefix? + (let ((not-dot (char-set-complement (char-set #\.)))) + (lambda (v1 v2) + "Return true if V1 is a version prefix of V2: + + (version-prefix? \"4.1\" \"4.16.2\") => #f + (version-prefix? \"4.1\" \"4.1.2\") => #t +" + (define (list-prefix? lst1 lst2) + (match lst1 + (() #t) + ((head1 tail1 ...) + (match lst2 + (() #f) + ((head2 tail2 ...) + (and (equal? head1 head2) + (list-prefix? tail1 tail2))))))) + + (list-prefix? (string-tokenize v1 not-dot) + (string-tokenize v2 not-dot))))) + (define (file-extension file) "Return the extension of FILE or #f if there is none." (let ((dot (string-rindex file #\.))) |