diff options
Diffstat (limited to 'guix')
31 files changed, 1718 insertions, 324 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 a6da530dab..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 @@ -233,7 +247,9 @@ repack them. This is necessary to ensure that archives are reproducible." (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/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/emacs-utils.scm b/guix/build/emacs-utils.scm index c1b00c7890..fdacd30dd6 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -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/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/r-build-system.scm b/guix/build/r-build-system.scm index 5e18939d22..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) 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/config.scm.in b/guix/config.scm.in index 8f2c4abd8e..dfe5fe0dbf 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 (and=> (getenv "NIX_DB_DIR") canonicalize-path) + (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 66d97eed44..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 () diff --git a/guix/gexp.scm b/guix/gexp.scm index 5ffe505be1..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,24 +1107,36 @@ 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 @@ -1097,7 +1175,47 @@ they can refer to each other." (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) 0)))) @@ -1129,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)) @@ -1151,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) @@ -1180,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/cran.scm b/guix/import/cran.scm index ec2b7e6029..49e5d2d358 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -128,9 +128,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/" 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 ab4b6278d6..a6f9936d63 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -388,10 +388,11 @@ 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 (%standard-patch-inputs) (let* ((canonical (module-ref (resolve-interface '(gnu packages base)) @@ -945,6 +946,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..9bddf88162 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -168,7 +168,7 @@ (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* @@ -318,7 +318,7 @@ denoting a specific output of a package." (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)))) - (($ <manifest-entry> name version output (? package? package) + (($ <manifest-entry> name version output package (deps ...) (search-paths ...)) #~(#$name #$version #$output (ungexp package (or output "out")) @@ -671,7 +671,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 +843,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 +1196,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 +1247,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 +1258,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 +1270,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 +1335,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)))) 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/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/lint.scm b/guix/scripts/lint.scm index 4ec3267007..cd802985dc 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1037,7 +1037,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/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/system.scm b/guix/scripts/system.scm index af501eb8f7..766cab1aad 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? diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index b4f790c9bf..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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,9 +21,11 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (gnu services) + #:use-module (gnu services shepherd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:export (service-type->recutils @@ -39,6 +42,27 @@ (define service-type-name* (compose symbol->string service-type-name)) +(define (service-type-default-shepherd-services type) + "Return the list of Shepherd services created by default instances of TYPE, +provided TYPE has a default value." + (match (guard (c ((service-error? c) #f)) + (service type)) + (#f '()) + ((? service? service) + (let* ((extension (find (lambda (extension) + (eq? (service-extension-target extension) + shepherd-root-service-type)) + (service-type-extensions type))) + (compute (and extension (service-extension-compute extension)))) + (if compute + (compute (service-value service)) + '()))))) + +(define (service-type-shepherd-names type) + "Return the default names of Shepherd services created for TYPE." + (append-map shepherd-service-provision + (service-type-default-shepherd-services type))) + (define* (service-type->recutils type port #:optional (width (%text-width)) #:key (extra-fields '())) @@ -66,6 +90,16 @@ columns." (format port "extends: ~a~%" (extensions->recutils (service-type-extensions type))) + ;; If possible, display the list of *default* Shepherd service names. Note + ;; that we may not always be able to do this (e.g., if the service type + ;; lacks a default value); furthermore, it could be that the service + ;; generates Shepherd services with different names if we give it different + ;; parameters (this is the case, for instance, for + ;; 'console-font-service-type'.) + (match (service-type-shepherd-names type) + (() #f) + (names (format port "shepherdnames:~{ ~a~}~%" names))) + (when (service-type-description type) (format port "~a~%" (string->recutils 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..3acfac6f80 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -82,6 +82,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 +93,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 +169,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 @@ -215,12 +218,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 +255,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 +295,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)) @@ -330,6 +363,7 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." *cli-modules* *system-modules* *package-modules* + *core-package-modules* *extra-modules* *core-modules*)) @@ -451,6 +485,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 +506,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 +522,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 +555,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 +589,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 +598,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"))))) ;;; 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 07c78289ff..45f438fc45 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -82,6 +82,7 @@ show-manifest-transaction call-with-error-handling with-error-handling + with-unbound-variable-handling leave-on-EPIPE read/eval read/eval-package-expression @@ -164,7 +165,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)))) @@ -179,9 +180,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) @@ -192,6 +193,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) @@ -244,12 +254,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) @@ -311,6 +316,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." @@ -331,16 +351,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) @@ -381,6 +393,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 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 #\.))) |