diff options
Diffstat (limited to 'guix')
97 files changed, 5874 insertions, 2252 deletions
diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm new file mode 100644 index 0000000000..d70535c9e3 --- /dev/null +++ b/guix/build-system/clojure.scm @@ -0,0 +1,195 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system clojure) + #:use-module (guix build clojure-utils) + #:use-module (guix build-system) + #:use-module (guix build-system ant) + #:use-module ((guix build-system gnu) + #:select (standard-packages) + #:prefix gnu:) + + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module ((guix search-paths) + #:select + ((search-path-specification->sexp . search-path-spec->sexp))) + #:use-module (guix utils) + + #:use-module (ice-9 match) + #:export (%clojure-build-system-modules + clojure-build + clojure-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Clojure packages. +;; +;; Code: + +(define-with-docs %clojure-build-system-modules + "Build-side modules imported and used by default." + `((guix build clojure-build-system) + (guix build clojure-utils) + (guix build guile-build-system) + ,@%ant-build-system-modules)) + +(define-with-docs %default-clojure + "The default Clojure package." + (delay (@* (gnu packages clojure) clojure))) + +(define-with-docs %default-jdk + "The default JDK package." + (delay (@* (gnu packages java) icedtea))) + +(define-with-docs %default-zip + "The default ZIP package." + (delay (@* (gnu packages compression) zip))) + +(define* (lower name + #:key + source target + inputs native-inputs + (clojure (force %default-clojure)) + (jdk (force %default-jdk)) + (zip (force %default-zip)) + outputs system + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (let ((private-keywords '(#:source #:target + #:inputs #:native-inputs + #:clojure #:jdk #:zip))) + + (if target + (error "No cross-compilation for clojure-build-system yet: LOWER" + target) ; FIXME + (bag (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(gnu:standard-packages))) + (build-inputs `(("clojure" ,clojure) + ("jdk" ,jdk "jdk") + ("zip" ,zip) + ,@native-inputs)) + (outputs outputs) + (build clojure-build) + (arguments (strip-keyword-arguments private-keywords + arguments)))))) + +(define-with-docs source->output-path + "Convert source input to output path." + (match-lambda + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source))) + +(define-with-docs maybe-guile->guile + "Find the right guile." + (match-lambda + ((and maybe-guile (? package?)) + maybe-guile) + (#f ; default + (@* (gnu packages commencement) guile-final)))) + +(define* (clojure-build store name inputs + #:key + (source-dirs `',%source-dirs) + (test-dirs `',%test-dirs) + (compile-dir %compile-dir) + + (jar-names `',(package-name->jar-names name)) + (main-class %main-class) + (omit-source? %omit-source?) + + (aot-include `',%aot-include) + (aot-exclude `',%aot-exclude) + + doc-dirs ; no sensible default + (doc-regex %doc-regex) + + (tests? %tests?) + (test-include `',%test-include) + (test-exclude `',%test-exclude) + + (phases '(@ (guix build clojure-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + + (imported-modules %clojure-build-system-modules) + (modules %clojure-build-system-modules)) + "Build SOURCE with INPUTS." + (let ((builder `(begin + (use-modules ,@modules) + (clojure-build #:name ,name + #:source ,(source->output-path + (assoc-ref inputs "source")) + + #:source-dirs ,source-dirs + #:test-dirs ,test-dirs + #:compile-dir ,compile-dir + + #:jar-names ,jar-names + #:main-class ,main-class + #:omit-source? ,omit-source? + + #:aot-include ,aot-include + #:aot-exclude ,aot-exclude + + #:doc-dirs ,doc-dirs + #:doc-regex ,doc-regex + + #:tests? ,tests? + #:test-include ,test-include + #:test-exclude ,test-exclude + + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-spec->sexp + search-paths) + #:system ,system + #:inputs %build-inputs))) + + (guile-for-build (package-derivation store + (maybe-guile->guile 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 clojure-build-system + (build-system + (name 'clojure) + (description "Simple Clojure build system using plain old 'compile'") + (lower lower))) + +;;; clojure.scm ends here diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index 13c89e8648..5a31a2f51a 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -35,13 +35,13 @@ (define (default-ldc) "Return the default ldc package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((ldc (resolve-interface '(gnu packages ldc)))) + (let ((ldc (resolve-interface '(gnu packages dlang)))) (module-ref ldc 'ldc))) (define (default-dub) "Return the default dub package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((ldc (resolve-interface '(gnu packages ldc)))) + (let ((ldc (resolve-interface '(gnu packages dlang)))) (module-ref ldc 'dub))) (define (default-pkg-config) diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 621e68e0ab..fcd92f2334 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -112,7 +112,7 @@ (configure-flags ''()) ;; Disable icon theme cache generation. (make-flags ''("gtk_update_icon_cache=true")) - (out-of-source? #t) + (out-of-source? #f) (tests? #t) (test-target "check") (parallel-build? #t) diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index 1cb734631c..1ec11c71d8 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -21,6 +21,7 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module (guix download) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) @@ -48,14 +49,35 @@ (let ((haskell (resolve-interface '(gnu packages haskell)))) (module-ref haskell 'ghc))) +(define (source-url->revision-url url revision) + "Convert URL (a Hackage source URL) to the URL for the Cabal file at +version REVISION." + (let* ((last-slash (string-rindex url #\/)) + (next-slash (string-rindex url #\/ 0 last-slash))) + (string-append (substring url 0 next-slash) + (substring url last-slash (- (string-length url) + (string-length ".tar.gz"))) + "/revision/" revision ".cabal"))) + (define* (lower name #:key source inputs native-inputs outputs system target (haskell (default-haskell)) + cabal-revision #:allow-other-keys #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:target #:haskell #:inputs #:native-inputs)) + '(#:target #:haskell #:cabal-revision #:inputs #:native-inputs)) + + (define (cabal-revision->origin cabal-revision) + (match cabal-revision + ((revision hash) + (origin + (method url-fetch) + (uri (source-url->revision-url (origin-uri source) revision)) + (sha256 (base32 hash)) + (file-name (string-append name "-" revision ".cabal")))) + (#f #f))) (and (not target) ;XXX: no cross-compilation (bag @@ -64,6 +86,9 @@ (host-inputs `(,@(if source `(("source" ,source)) '()) + ,@(match (cabal-revision->origin cabal-revision) + (#f '()) + (revision `(("cabal-revision" ,revision)))) ,@inputs ;; Keep the standard inputs of 'gnu-build-system'. @@ -103,6 +128,11 @@ provides a 'Setup.hs' file as its build system." source) (source source)) + #:cabal-revision ,(match (assoc-ref inputs + "cabal-revision") + (((? derivation? revision)) + (derivation->output-path revision)) + (revision revision)) #:configure-flags ,configure-flags #:haddock-flags ,haddock-flags #:system ,system diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index fddf899092..8d49020454 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -41,7 +41,6 @@ (define %meson-build-system-modules ;; Build-side modules imported by default. `((guix build meson-build-system) - (guix build rpath) ;; The modules from glib-or-gtk contains the modules from gnu-build-system, ;; so there is no need to import that too. ,@%glib-or-gtk-build-system-modules)) diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 34a22ecffa..e5b715f55d 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2016, 2017, 2018 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2017 Ben Woodcroft <donttrustben@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -28,7 +28,9 @@ #:use-module (srfi srfi-1) #:export (%ocaml-build-system-modules package-with-ocaml4.01 + package-with-ocaml4.02 strip-ocaml4.01-variant + strip-ocaml4.02-variant ocaml-build ocaml-build-system)) @@ -82,6 +84,14 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml4.01-findlib))) +(define (default-ocaml4.02) + (let ((ocaml (resolve-interface '(gnu packages ocaml)))) + (module-ref ocaml 'ocaml-4.02))) + +(define (default-ocaml4.02-findlib) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml4.02-findlib))) + (define* (package-with-explicit-ocaml ocaml findlib old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package @@ -139,12 +149,24 @@ pre-defined variants." "ocaml-" "ocaml4.01-" #:variant-property 'ocaml4.01-variant)) +(define package-with-ocaml4.02 + (package-with-explicit-ocaml (delay (default-ocaml4.02)) + (delay (default-ocaml4.02-findlib)) + "ocaml-" "ocaml4.02-" + #:variant-property 'ocaml4.02-variant)) + (define (strip-ocaml4.01-variant p) "Remove the 'ocaml4.01-variant' property from P." (package (inherit p) (properties (alist-delete 'ocaml4.01-variant (package-properties p))))) +(define (strip-ocaml4.02-variant p) + "Remove the 'ocaml4.02-variant' property from P." + (package + (inherit p) + (properties (alist-delete 'ocaml4.02-variant (package-properties p))))) + (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index ffed837313..b753940bad 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -50,7 +50,7 @@ "Return a URI string for the Python package hosted on the Python Package Index (PyPI) corresponding to NAME and VERSION. EXTENSION is the file name extension, such as '.tar.gz'." - (string-append "https://pypi.io/packages/source/" + (string-append "https://pypi.org/packages/source/" (string-take name 1) "/" name "/" name "-" version extension)) diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index d5f897932f..664515d0ee 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.7/bioc/src/contrib/Archive/" + (string-append "https://bioconductor.org/packages/3.8/bioc/src/contrib/Archive/" name "_" version ".tar.gz"))) (define %r-build-system-modules diff --git a/guix/build/clojure-build-system.scm b/guix/build/clojure-build-system.scm new file mode 100644 index 0000000000..d8f7c89f85 --- /dev/null +++ b/guix/build/clojure-build-system.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build clojure-build-system) + #:use-module ((guix build ant-build-system) + #:select ((%standard-phases . %standard-phases@ant) + ant-build)) + #:use-module (guix build clojure-utils) + #:use-module (guix build java-utils) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + clojure-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Clojure packages. +;; +;; Code: + +(define* (build #:key + source-dirs compile-dir + jar-names main-class omit-source? + aot-include aot-exclude + #:allow-other-keys) + "Standard 'build' phase for clojure-build-system." + (let* ((libs (append-map find-clojure-libs source-dirs)) + (libs* (include-list\exclude-list aot-include + aot-exclude + #:all-list libs))) + (mkdir-p compile-dir) + (eval-with-clojure `(run! compile ',libs*) + source-dirs) + (let ((source-dir-files-alist (map (lambda (dir) + (cons dir (find-files* dir))) + source-dirs)) + ;; workaround transitive compilation in Clojure + (classes (filter (lambda (class) + (any (cut compiled-from? class <>) + libs*)) + (find-files* compile-dir)))) + (for-each (cut create-jar <> (cons (cons compile-dir classes) + (if omit-source? + '() + source-dir-files-alist)) + #:main-class main-class) + jar-names) + #t))) + +(define* (check #:key + test-dirs + jar-names + tests? test-include test-exclude + #:allow-other-keys) + "Standard 'check' phase for clojure-build-system. Note that TEST-EXCLUDE has +priority over TEST-INCLUDE." + (if tests? + (let* ((libs (append-map find-clojure-libs test-dirs)) + (libs* (include-list\exclude-list test-include + test-exclude + #:all-list libs))) + (for-each (lambda (jar) + (eval-with-clojure `(do (apply require + '(clojure.test ,@libs*)) + (apply clojure.test/run-tests + ',libs*)) + (cons jar test-dirs))) + jar-names))) + #t) + +(define-with-docs install + "Standard 'install' phase for clojure-build-system." + (install-jars "./")) + +(define-with-docs %standard-phases + "Standard build phases for clojure-build-system." + (modify-phases %standard-phases@ant + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install-license-files 'install-doc install-doc))) + +(define* (clojure-build #:key + inputs + (phases %standard-phases) + #:allow-other-keys + #:rest args) + "Build the given Clojure package, applying all of PHASES in order." + (apply ant-build + #:inputs inputs + #:phases phases + args)) + +;;; clojure-build-system.scm ends here diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm new file mode 100644 index 0000000000..027777b4d1 --- /dev/null +++ b/guix/build/clojure-utils.scm @@ -0,0 +1,265 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build clojure-utils) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-26) + #:export (@* + @@* + define-with-docs + + %doc-regex + install-doc + + %source-dirs + %test-dirs + %compile-dir + package-name->jar-names + %main-class + %omit-source? + %aot-include + %aot-exclude + %tests? + %test-include + %test-exclude + + %clojure-regex + canonicalize-relative-path + find-files* + file-sans-extension + relative-path->clojure-lib-string + find-clojure-libs + compiled-from? + include-list\exclude-list + eval-with-clojure + create-jar)) + +(define-syntax-rule (@* module name) + "Like (@ MODULE NAME), but resolves at run time." + (module-ref (resolve-interface 'module) 'name)) + +(define-syntax-rule (@@* module name) + "Like (@@ MODULE NAME), but resolves at run time." + (module-ref (resolve-module 'module) 'name)) + +(define-syntax-rule (define-with-docs name docs val) + "Create top-level variable named NAME with doc string DOCS and value VAL." + (begin (define name val) + (set-object-property! name 'documentation docs))) + +(define-with-docs %doc-regex + "Default regex for matching the base name of top-level documentation files." + (format #f + "(~a)|(\\.(html|markdown|md|txt)$)" + (@@ (guix build guile-build-system) + %documentation-file-regexp))) + +(define* (install-doc #:key + doc-dirs + (doc-regex %doc-regex) + outputs + #:allow-other-keys) + "Install the following to the default documentation directory: + +1. Top-level files with base name matching DOC-REGEX. +2. All files (recursively) inside DOC-DIRS. + +DOC-REGEX can be compiled or uncompiled." + (let* ((out (assoc-ref outputs "out")) + (doc (assoc-ref outputs "doc")) + (name-ver (strip-store-file-name out)) + (dest-dir (string-append (or doc out) "/share/doc/" name-ver "/")) + (doc-regex* (if (string? doc-regex) + (make-regexp doc-regex) + doc-regex))) + (for-each (cut install-file <> dest-dir) + (remove (compose file-exists? + (cut string-append dest-dir <>)) + (scandir "./" (cut regexp-exec doc-regex* <>)))) + (for-each (cut copy-recursively <> dest-dir) + doc-dirs) + #t)) + +(define-with-docs %source-dirs + "A default list of source directories." + '("src/")) + +(define-with-docs %test-dirs + "A default list of test directories." + '("test/")) + +(define-with-docs %compile-dir + "Default directory for holding class files." + "classes/") + +(define (package-name->jar-names name) + "Given NAME, a package name like \"foo-0.9.1b\", +return the list of default jar names: (\"foo-0.9.1b.jar\" \"foo.jar\")." + (map (cut string-append <> ".jar") + (list name + (receive (base-name _) + (package-name->name+version name) + base-name)))) + +(define-with-docs %main-class + "Default name for main class. It should be a symbol or #f." + #f) + +(define-with-docs %omit-source? + "Include source in jars by default." + #f) + +(define-with-docs %aot-include + "A default list of symbols deciding what to compile. Note that the exclude +list has priority over the include list. The special keyword #:all represents +all libraries found under the source directories." + '(#:all)) + +(define-with-docs %aot-exclude + "A default list of symbols deciding what not to compile. +See the doc string of '%aot-include' for more details." + '()) + +(define-with-docs %tests? + "Enable tests by default." + #t) + +(define-with-docs %test-include + "A default list of symbols deciding what tests to include. Note that the +exclude list has priority over the include list. The special keyword #:all +represents all tests found under the test directories." + '(#:all)) + +(define-with-docs %test-exclude + "A default list of symbols deciding what tests to exclude. +See the doc string of '%test-include' for more details." + '()) + +(define-with-docs %clojure-regex + "Default regex for matching the base name of clojure source files." + "\\.cljc?$") + +(define-with-docs canonicalize-relative-path + "Like 'canonicalize-path', but for relative paths. +Canonicalizations requiring the path to exist are omitted." + (let ((remove.. (lambda (ls) + (fold-right (match-lambda* + (((and comp (not "..")) (".." comps ...)) + comps) + ((comp (comps ...)) + (cons comp comps))) + '() + ls)))) + (compose (match-lambda + (() ".") + (ls (string-join ls "/"))) + remove.. + (cut remove (cut member <> '("" ".")) <>) + (cut string-split <> #\/)))) + +(define (find-files* base-dir . args) + "Similar to 'find-files', but with BASE-DIR stripped and result +canonicalized." + (map canonicalize-relative-path + (with-directory-excursion base-dir + (apply find-files "./" args)))) + +;;; FIXME: should be moved to (guix build utils) +(define-with-docs file-sans-extension + "Strip extension from path, if any." + (@@ (guix build guile-build-system) + file-sans-extension)) + +(define (relative-path->clojure-lib-string path) + "Convert PATH to a clojure library string." + (string-map (match-lambda + (#\/ #\.) + (#\_ #\-) + (chr chr)) + (file-sans-extension path))) + +(define* (find-clojure-libs base-dir + #:key (clojure-regex %clojure-regex)) + "Return the list of clojure libraries found under BASE-DIR. + +CLOJURE-REGEX can be compiled or uncompiled." + (map (compose string->symbol + relative-path->clojure-lib-string) + (find-files* base-dir clojure-regex))) + +(define (compiled-from? class lib) + "Given class file CLASS and clojure library symbol LIB, decide if CLASS +results from compiling LIB." + (string-prefix? (symbol->string lib) + (relative-path->clojure-lib-string class))) + +(define* (include-list\exclude-list include-list exclude-list + #:key all-list) + "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurences of #:all by +slicing ALL-LIST into them and compute their list difference." + (define (replace-#:all ls all-ls) + (append-map (match-lambda + (#:all all-ls) + (x (list x))) + ls)) + (let ((include-list* (replace-#:all include-list all-list)) + (exclude-list* (replace-#:all exclude-list all-list))) + (lset-difference equal? include-list* exclude-list*))) + +(define (eval-with-clojure expr extra-paths) + "Evaluate EXPR with clojure. + +EXPR must be a s-expression writable by guile and readable by clojure. +For examples, '(require '[clojure.string]) will not work, +because the guile writer converts brackets to parentheses. + +EXTRA-PATHS is a list of paths which will be appended to $CLASSPATH." + (let* ((classpath (getenv "CLASSPATH")) + (classpath* (string-join (cons classpath extra-paths) ":"))) + (invoke "java" + "-classpath" classpath* + "clojure.main" + "--eval" (object->string expr)))) + +(define* (create-jar output-jar dir-files-alist + #:key + (verbose? #t) + (compress? #f) + (main-class %main-class)) + "Given DIR-FILES-ALIST, an alist of the form: ((DIR . FILES) ...) +Create jar named OUTPUT-JAR from FILES with DIR stripped." + (let ((grouped-options (string-append "c" + (if verbose? "v" "") + "f" + (if compress? "" "0") + (if main-class "e" "")))) + (apply invoke `("jar" + ,grouped-options + ,output-jar + ,@(if main-class (list (symbol->string main-class)) '()) + ,@(append-map (match-lambda + ((dir . files) + (append-map (lambda (file) + `("-C" ,dir ,file)) + files))) + dir-files-alist))))) diff --git a/guix/build/download.scm b/guix/build/download.scm index 315a3554ec..54163849a2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -115,7 +115,7 @@ and 'guix publish', something like (string-drop path 33) path))) -(define* (ftp-fetch uri file #:key timeout) +(define* (ftp-fetch uri file #:key timeout print-build-trace?) "Fetch data from URI and write it to FILE. Return FILE on success. Bail out if the connection could not be established in less than TIMEOUT seconds." (let* ((conn (match (and=> (uri-userinfo uri) @@ -136,12 +136,17 @@ out if the connection could not be established in less than TIMEOUT seconds." (lambda (out) (dump-port* in out #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)))) - - (ftp-close conn)) - (newline) - file) + #:reporter + (if print-build-trace? + (progress-reporter/trace + file (uri->string uri) size) + (progress-reporter/file + (uri-abbreviation uri) size))))) + + (ftp-close conn) + (unless print-build-trace? + (newline)) + file)) ;; Autoload GnuTLS so that this module can be used even when GnuTLS is ;; not available. At compile time, this yields "possibly unbound @@ -723,7 +728,8 @@ Return a list of URIs." #:key (timeout 10) (verify-certificate? #t) (mirrors '()) (content-addressed-mirrors '()) - (hashes '())) + (hashes '()) + print-build-trace?) "Fetch FILE from URL; URL may be either a single string, or a list of string denoting alternate URLs for FILE. Return #f on failure, and FILE on success. @@ -759,13 +765,18 @@ otherwise simply ignore them." (lambda (output) (dump-port* port output #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)) + #:reporter (if print-build-trace? + (progress-reporter/trace + file (uri->string uri) size) + (progress-reporter/file + (uri-abbreviation uri) size))) (newline))) file))) ((ftp) (false-if-exception* (ftp-fetch uri file - #:timeout timeout))) + #:timeout timeout + #:print-build-trace? + print-build-trace?))) (else (format #t "skipping URI with unsupported scheme: ~s~%" uri) diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm index 9a72e3d544..3ab50733de 100644 --- a/guix/build/dub-build-system.scm +++ b/guix/build/dub-build-system.scm @@ -67,7 +67,8 @@ (symlink (string-append path "/lib/dub/" d-basename) (string-append vendor-dir "/" d-basename)))))))) inputs) - (zero? (system* "dub" "add-path" vendor-dir)))) + (invoke "dub" "add-path" vendor-dir) + #t)) (define (grep string file-name) "Find the first occurrence of STRING in the file named FILE-NAME. @@ -88,24 +89,22 @@ (define* (build #:key (dub-build-flags '()) #:allow-other-keys) "Build a given DUB package." - (if (or (grep* "sourceLibrary" "package.json") - (grep* "sourceLibrary" "dub.sdl") ; note: format is different! - (grep* "sourceLibrary" "dub.json")) - #t - (let ((status (zero? (apply system* `("dub" "build" ,@dub-build-flags))))) - (substitute* ".dub/dub.json" - (("\"lastUpgrade\": \"[^\"]*\"") - "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\"")) - status))) + (unless (or (grep* "sourceLibrary" "package.json") + (grep* "sourceLibrary" "dub.sdl") ; note: format is different! + (grep* "sourceLibrary" "dub.json")) + (apply invoke `("dub" "build" ,@dub-build-flags)) + (substitute* ".dub/dub.json" + (("\"lastUpgrade\": \"[^\"]*\"") + "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))) + #t) (define* (check #:key tests? #:allow-other-keys) - (if tests? - (let ((status (zero? (system* "dub" "test")))) - (substitute* ".dub/dub.json" - (("\"lastUpgrade\": \"[^\"]*\"") - "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\"")) - status) - #t)) + (when tests? + (invoke "dub" "test") + (substitute* ".dub/dub.json" + (("\"lastUpgrade\": \"[^\"]*\"") + "\"lastUpgrade\": \"1970-01-01T00:00:00.0000000\""))) + #t) (define* (install #:key inputs outputs #:allow-other-keys) "Install a given DUB package." diff --git a/guix/build/git.scm b/guix/build/git.scm index 14d415a6f8..2d1700a9b9 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -45,6 +45,8 @@ recursively. Return #t on success, #f otherwise." (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) (invoke git-command "checkout" "FETCH_HEAD") (begin + (setvbuf (current-output-port) 'line) + (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") (invoke git-command "fetch" "origin") (invoke git-command "checkout" commit))) (when recursive? diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index be5ad78b93..e5f3197b0a 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -792,26 +792,26 @@ in order. Return #t if all the PHASES succeeded, #f otherwise." ;; The trick is to #:allow-other-keys everywhere, so that each procedure in ;; PHASES can pick the keyword arguments it's interested in. - (for-each (match-lambda - ((name . proc) - (let ((start (current-time time-monotonic))) - (format #t "starting phase `~a'~%" name) - (let ((result (apply proc args)) - (end (current-time time-monotonic))) - (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" - name result - (elapsed-time end start)) - - ;; Issue a warning unless the result is #t. - (unless (eqv? result #t) - (format (current-error-port) "\ + (every (match-lambda + ((name . proc) + (let ((start (current-time time-monotonic))) + (format #t "starting phase `~a'~%" name) + (let ((result (apply proc args)) + (end (current-time time-monotonic))) + (format #t "phase `~a' ~:[failed~;succeeded~] after ~,1f seconds~%" + name result + (elapsed-time end start)) + + ;; Issue a warning unless the result is #t. + (unless (eqv? result #t) + (format (current-error-port) "\ ## WARNING: phase `~a' returned `~s'. Return values other than #t ## are deprecated. Please migrate this package so that its phase ## procedures report errors by raising an exception, and otherwise ## always return #t.~%" - name result)) + name result)) - ;; Dump the environment variables as a shell script, for handy debugging. - (system "export > $NIX_BUILD_TOP/environment-variables") - result)))) - phases)) + ;; Dump the environment variables as a shell script, for handy debugging. + (system "export > $NIX_BUILD_TOP/environment-variables") + result)))) + phases)) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 6be0167063..022d4fe16b 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -204,6 +204,9 @@ respectively." $GOPATH/pkg, so we have to copy them into the output directory manually. Compiled executable files should have already been installed to the store based on $GOBIN in the build phase." + ;; TODO: From go-1.10 onward, the pkg folder should not be needed (see + ;; https://lists.gnu.org/archive/html/guix-devel/2018-11/msg00208.html). + ;; Remove it? (when (file-exists? "pkg") (copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg"))) #t) diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm index bb019967e5..e8ea66dfb3 100644 --- a/guix/build/gremlin.scm +++ b/guix/build/gremlin.scm @@ -41,7 +41,8 @@ elf-dynamic-info-runpath expand-origin - validate-needed-in-runpath)) + validate-needed-in-runpath + strip-runpath)) ;;; Commentary: ;;; @@ -99,10 +100,16 @@ dynamic linking information." ;; } d_un; ;; } Elf64_Dyn; +(define-record-type <dynamic-entry> + (dynamic-entry type value offset) + dynamic-entry? + (type dynamic-entry-type) ;DT_* + (value dynamic-entry-value) ;string | number | ... + (offset dynamic-entry-offset)) ;integer + (define (raw-dynamic-entries elf segment) - "Return as a list of type/value pairs all the dynamic entries found in -SEGMENT, the 'PT_DYNAMIC' segment of ELF. In the result, each car is a DT_ -value, and the interpretation of the cdr depends on the type." + "Return as a list of <dynamic-entry> for the dynamic entries found in +SEGMENT, the 'PT_DYNAMIC' segment of ELF." (define start (elf-segment-offset segment)) (define bytes @@ -123,7 +130,9 @@ value, and the interpretation of the cdr depends on the type." (if (= type DT_NULL) ;finished? (reverse result) (loop (+ offset (* 2 word-size)) - (alist-cons type value result))))))) + (cons (dynamic-entry type value + (+ start offset word-size)) + result))))))) (define (vma->offset elf vma) "Convert VMA, a virtual memory address, to an offset within ELF. @@ -148,35 +157,33 @@ offset." (define (dynamic-entries elf segment) "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment -of ELF, as a list of type/value pairs. The type is a DT_ value, and the value -may be a string or an integer depending on the entry type (for instance, the -value of DT_NEEDED entries is a string.)" +of ELF, as a list of <dynamic-entry>. The value of each entry may be a string +or an integer depending on the entry type (for instance, the value of +DT_NEEDED entries is a string.) Likewise the offset is the offset within the +string table if the type is a string." (define entries (raw-dynamic-entries elf segment)) (define string-table-offset - (any (match-lambda - ((type . value) - (and (= type DT_STRTAB) value)) - (_ #f)) + (any (lambda (entry) + (and (= (dynamic-entry-type entry) DT_STRTAB) + (dynamic-entry-value entry))) entries)) - (define (interpret-dynamic-entry type value) - (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH)) - (if string-table-offset - (pointer->string - (bytevector->pointer (elf-bytes elf) - (vma->offset - elf - (+ string-table-offset value)))) - value)) - (else - value))) - - (map (match-lambda - ((type . value) - (cons type (interpret-dynamic-entry type value)))) - entries)) + (define (interpret-dynamic-entry entry) + (let ((type (dynamic-entry-type entry)) + (value (dynamic-entry-value entry))) + (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH)) + (if string-table-offset + (let* ((offset (vma->offset elf (+ string-table-offset value))) + (value (pointer->string + (bytevector->pointer (elf-bytes elf) offset)))) + (dynamic-entry type value offset)) + (dynamic-entry type value (dynamic-entry-offset entry)))) + (else + (dynamic-entry type value (dynamic-entry-offset entry)))))) + + (map interpret-dynamic-entry entries)) ;;; @@ -200,21 +207,29 @@ value of DT_NEEDED entries is a string.)" (define (elf-dynamic-info elf) "Return dynamic-link information for ELF as an <elf-dynamic-info> object, or #f if ELF lacks dynamic-link information." + (define (matching-entry type) + (lambda (entry) + (= type (dynamic-entry-type entry)))) + (match (dynamic-link-segment elf) (#f #f) ((? elf-segment? dynamic) (let ((entries (dynamic-entries elf dynamic))) - (%elf-dynamic-info (assv-ref entries DT_SONAME) - (filter-map (match-lambda - ((type . value) - (and (= type DT_NEEDED) value)) - (_ #f)) + (%elf-dynamic-info (find (matching-entry DT_SONAME) entries) + (filter-map (lambda (entry) + (and (= (dynamic-entry-type entry) + DT_NEEDED) + (dynamic-entry-value entry))) entries) - (or (and=> (assv-ref entries DT_RPATH) - search-path->list) + (or (and=> (find (matching-entry DT_RPATH) + entries) + (compose search-path->list + dynamic-entry-value)) '()) - (or (and=> (assv-ref entries DT_RUNPATH) - search-path->list) + (or (and=> (find (matching-entry DT_RUNPATH) + entries) + (compose search-path->list + dynamic-entry-value)) '())))))) (define %libc-libraries @@ -306,4 +321,47 @@ be found in RUNPATH ~s~%" ;; (format (current-error-port) "~a is OK~%" file)) (null? not-found)))))) +(define (strip-runpath file) + "Remove from the DT_RUNPATH of FILE any entries that are not necessary +according to DT_NEEDED." + (define (minimal-runpath needed runpath) + (filter (lambda (directory) + (and (string-prefix? "/" directory) + (any (lambda (lib) + (file-exists? (string-append directory "/" lib))) + needed))) + runpath)) + + (define port + (open-file file "r+b")) + + (catch #t + (lambda () + (let* ((elf (parse-elf (get-bytevector-all port))) + (entries (dynamic-entries elf (dynamic-link-segment elf))) + (needed (filter-map (lambda (entry) + (and (= (dynamic-entry-type entry) + DT_NEEDED) + (dynamic-entry-value entry))) + entries)) + (runpath (find (lambda (entry) + (= DT_RUNPATH (dynamic-entry-type entry))) + entries)) + (old (search-path->list + (dynamic-entry-value runpath))) + (new (minimal-runpath needed old))) + (unless (equal? old new) + (format (current-error-port) + "~a: stripping RUNPATH to ~s (removed ~s)~%" + file new + (lset-difference string=? old new)) + (seek port (dynamic-entry-offset runpath) SEEK_SET) + (put-bytevector port (string->utf8 (string-join new ":"))) + (put-u8 port 0)) + (close-port port) + new)) + (lambda (key . args) + (false-if-exception (close-port port)) + (apply throw key args)))) + ;;; gremlin.scm ends here diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 26519ce5a6..23d97e6602 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -2,6 +2,8 @@ ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +29,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 vlist) + #:use-module (ice-9 ftw) #:export (%standard-phases haskell-build)) @@ -76,6 +79,7 @@ and parameters ~s~%" (doc (assoc-ref outputs "doc")) (lib (assoc-ref outputs "lib")) (bin (assoc-ref outputs "bin")) + (name-version (strip-store-file-name out)) (input-dirs (match inputs (((_ . dir) ...) dir) @@ -86,7 +90,7 @@ and parameters ~s~%" `(,(string-append "--bindir=" (or bin out) "/bin")) `(,(string-append "--docdir=" (or doc out) - "/share/doc/" (package-name-version out))) + "/share/doc/" name-version)) '("--libsubdir=$compiler/$pkg-$version") `(,(string-append "--package-db=" %tmp-db-dir)) '("--global") @@ -125,12 +129,6 @@ and parameters ~s~%" "Install a given Haskell package." (run-setuphs "copy" '())) -(define (package-name-version store-dir) - "Given a store directory STORE-DIR return 'name-version' of the package." - (let* ((base (basename store-dir))) - (string-drop base - (+ 1 (string-index base #\-))))) - (define (grep rx port) "Given a regular-expression RX including a group, read from PORT until the first match and return the content of the group." @@ -145,7 +143,7 @@ first match and return the content of the group." (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." (let* ((haskell (assoc-ref inputs "haskell")) - (name-version (package-name-version haskell))) + (name-version (strip-store-file-name haskell))) (cond ((string-match "ghc" name-version) (make-ghc-package-database system inputs outputs)) @@ -162,6 +160,7 @@ first match and return the content of the group." (define (make-ghc-package-database system inputs outputs) "Generate the GHC package database." (let* ((haskell (assoc-ref inputs "haskell")) + (name-version (strip-store-file-name haskell)) (input-dirs (match inputs (((_ . dir) ...) dir) @@ -169,7 +168,7 @@ first match and return the content of the group." ;; Silence 'find-files' (see 'evaluate-search-paths') (conf-dirs (with-null-error-port (search-path-as-list - `(,(string-append "lib/" (package-name-version haskell))) + `(,(string-append "lib/" name-version)) input-dirs #:pattern ".*\\.conf.d$"))) (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs))) (mkdir-p %tmp-db-dir) @@ -178,9 +177,10 @@ first match and return the content of the group." (unless (file-exists? dest) (copy-file file dest)))) conf-files) - (zero? (system* "ghc-pkg" - (string-append "--package-db=" %tmp-db-dir) - "recache")))) + (invoke "ghc-pkg" + (string-append "--package-db=" %tmp-db-dir) + "recache") + #t)) (define* (register #:key name system inputs outputs #:allow-other-keys) "Generate the compiler registration and binary package database files for a @@ -228,9 +228,10 @@ given Haskell package." (let* ((out (assoc-ref outputs "out")) (haskell (assoc-ref inputs "haskell")) + (name-verion (strip-store-file-name haskell)) (lib (string-append out "/lib")) - (config-dir (string-append lib "/" - (package-name-version haskell) + (config-dir (string-append lib + "/" name-verion "/" name ".conf.d")) (id-rx (make-regexp "^id: *(.*)$")) (config-file (string-append out "/" name ".conf")) @@ -238,35 +239,45 @@ given Haskell package." (list (string-append "--gen-pkg-config=" config-file)))) (run-setuphs "register" params) ;; The conf file is created only when there is a library to register. - (or (not (file-exists? config-file)) - (begin - (mkdir-p config-dir) - (let* ((config-file-name+id - (call-with-ascii-input-file config-file (cut grep id-rx <>)))) - (install-transitive-deps config-file %tmp-db-dir config-dir) - (rename-file config-file - (string-append config-dir "/" - config-file-name+id ".conf")) - (zero? (system* "ghc-pkg" - (string-append "--package-db=" config-dir) - "recache"))))))) + (when (file-exists? config-file) + (mkdir-p config-dir) + (let* ((config-file-name+id + (call-with-ascii-input-file config-file (cut grep id-rx <>)))) + (install-transitive-deps config-file %tmp-db-dir config-dir) + (rename-file config-file + (string-append config-dir "/" + config-file-name+id ".conf")) + (invoke "ghc-pkg" + (string-append "--package-db=" config-dir) + "recache"))) + #t)) (define* (check #:key tests? test-target #:allow-other-keys) "Run the test suite of a given Haskell package." (if tests? (run-setuphs test-target '()) - (begin - (format #t "test suite not run~%") - #t))) + (format #t "test suite not run~%")) + #t) (define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys) "Run the test suite of a given Haskell package." - (if haddock? - (run-setuphs "haddock" haddock-flags) - #t)) + (when haddock? + (run-setuphs "haddock" haddock-flags)) + #t) + +(define* (patch-cabal-file #:key cabal-revision #:allow-other-keys) + (when cabal-revision + ;; Cabal requires there to be a single file with the suffix ".cabal". + (match (scandir "." (cut string-suffix? ".cabal" <>)) + ((original) + (format #t "replacing ~s with ~s~%" original cabal-revision) + (copy-file cabal-revision original)) + (_ (error "Could not find a Cabal file to patch.")))) + #t) (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'patch-cabal-file patch-cabal-file) (delete 'bootstrap) (add-before 'configure 'setup-compiler setup-compiler) (add-before 'install 'haddock haddock) diff --git a/guix/build/hg.scm b/guix/build/hg.scm index ea51eb670b..b3e3ff7ac3 100644 --- a/guix/build/hg.scm +++ b/guix/build/hg.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> +;;; Copyright © 2018 Björn Höfling <bjoern.hoefling@bjoernhoefling.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,8 +46,10 @@ Mercurial changeset identifier. Return #t on success, #f otherwise." ;; The contents of '.hg' vary as a function of the current ;; status of the Mercurial repo. Since we want a fixed ;; output, this directory needs to be taken out. - (with-directory-excursion directory - (delete-file-recursively ".hg")) + ;; Since the '.hg' file is also in sub-modules, we have to + ;; search for it in all sub-directories. + (for-each delete-file-recursively + (find-files directory "^\\.hg$" #:directories? #t)) #t) diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm index 128be1edeb..8200638bee 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,12 +24,6 @@ install-jars install-javadoc)) -;; Copied from haskell-build-system.scm -(define (package-name-version store-dir) - "Given a store directory STORE-DIR return 'name-version' of the package." - (let* ((base (basename store-dir))) - (string-drop base (+ 1 (string-index base #\-))))) - (define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) #:allow-other-keys) (apply invoke `("ant" ,target ,@make-flags))) @@ -48,8 +43,9 @@ is used in case the build.xml does not include an install target." install javadocs when this is not done by the install target." (lambda* (#:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) + (name-version (strip-store-file-name out)) (docs (string-append (or (assoc-ref outputs "doc") out) - "/share/doc/" (package-name-version out) "/"))) + "/share/doc/" name-version "/"))) (mkdir-p docs) (copy-recursively apidoc-directory docs) #t))) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 21cb620d59..97bc6197a3 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -81,6 +81,21 @@ "Replace invalid characters in STR with a hyphen." (string-join (string-tokenize str valid-char-set) "-")) +(define (normalize-dependency dependency) + "Normalize the name of DEPENDENCY. Handles dependency definitions of the +dependency-def form described by +<https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>. +Assume that any symbols in DEPENDENCY will be in upper-case." + (match dependency + ((':VERSION name rest ...) + `(:version ,(normalize-string name) ,@rest)) + ((':FEATURE feature-specification dependency-specification) + `(:feature + ,feature-specification + ,(normalize-dependency dependency-specification))) + ((? string? name) (normalize-string name)) + (require-specification require-specification))) + (define (inputs->asd-file-map inputs) "Produce a hash table of the form (system . asd-file), where system is the name of an ASD system, and asd-file is the full path to its definition." @@ -105,9 +120,9 @@ name of an ASD system, and asd-file is the full path to its definition." (define (lisp-eval-program program) "Evaluate PROGRAM with a given LISP implementation." - (unless (zero? (apply system* - (lisp-invocation program))) - (error "lisp-eval-program failed!" (%lisp) program))) + (define invocation (lisp-invocation program)) + (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation) + (apply invoke invocation)) (define (spread-statements program argument-name) "Return a list with the statements from PROGRAM spread between @@ -138,8 +153,7 @@ with PROGRAM." first." (lisp-eval-program `((require :asdf) - (let ((*package* (find-package :asdf))) - (load ,asd-file)) + (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) (asdf:operate 'asdf:compile-bundle-op ,system)))) (define (system-dependencies system asd-file) @@ -148,8 +162,7 @@ asdf:system-depends-on. First load the system's ASD-FILE." (define deps-file ".deps.sexp") (define program `((require :asdf) - (let ((*package* (find-package :asdf))) - (load ,asd-file)) + (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) (with-open-file (stream ,deps-file :direction :output) (format stream @@ -189,19 +202,18 @@ asdf:system-depends-on. First load the system's ASD-FILE." Also load TEST-ASD-FILE if necessary." (lisp-eval-program `((require :asdf) - (let ((*package* (find-package :asdf))) - (load ,asd-file) - ,@(if test-asd-file - `((load ,test-asd-file)) - ;; Try some likely files. - (map (lambda (file) - `(when (uiop:file-exists-p ,file) - (load ,file))) - (list - (string-append system "-tests.asd") - (string-append system "-test.asd") - "tests.asd" - "test.asd")))) + (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) + ,@(if test-asd-file + `((asdf:load-asd (truename ,test-asd-file))) + ;; Try some likely files. + (map (lambda (file) + `(when (uiop:file-exists-p ,file) + (asdf:load-asd (truename ,file)))) + (list + (string-append system "-tests.asd") + (string-append system "-test.asd") + "tests.asd" + "test.asd"))) (asdf:test-system ,system)))) (define (string->lisp-keyword . strings) @@ -273,16 +285,24 @@ system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS." (system-dependencies system system-asd-file))) (if (eq? 'NIL deps) '() - (map normalize-string deps)))) + (map normalize-dependency deps)))) (define lisp-input-map (inputs->asd-file-map inputs)) + (define dependency-name + (match-lambda + ((':version name _ ...) name) + ((':feature _ dependency-specification) + (dependency-name dependency-specification)) + ((? string? name) name) + (_ #f))) + (define registry (filter-map hash-get-handle (make-list (length dependencies) lisp-input-map) - dependencies)) + (map dependency-name dependencies))) (call-with-output-file asd-file (lambda (port) diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm index 80e54723c5..d0975fcab0 100644 --- a/guix/build/meson-build-system.scm +++ b/guix/build/meson-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> ;;; ;;; This file is part of GNU Guix. @@ -21,7 +22,6 @@ #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:) #:use-module (guix build utils) - #:use-module (guix build rpath) #:use-module (guix build gremlin) #:use-module (guix elf) #:use-module (ice-9 match) @@ -71,49 +71,19 @@ "1")) (if tests? (invoke "ninja" test-target) - (begin - (format #t "test suite not run~%") - #t))) + (format #t "test suite not run~%")) + #t) (define* (install #:rest args) (invoke "ninja" "install")) -(define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec" - "bin" "sbin")) - outputs #:allow-other-keys) - "Try to make sure all ELF files in ELF-DIRECTORIES are able to find their -local dependencies in their RUNPATH, by searching for the needed libraries in -the directories of the package, and adding them to the RUNPATH if needed. -Also shrink the RUNPATH to what is needed, +(define* (shrink-runpath #:key (elf-directories '("lib" "lib64" "libexec" + "bin" "sbin")) + outputs #:allow-other-keys) + "Go through all ELF files from ELF-DIRECTORIES and shrink the RUNPATH since a lot of directories are left over from the build phase of meson, for example libraries only needed for the tests." - ;; Find the directories (if any) that contains DEP-NAME. The directories - ;; searched are the ones that ELF-FILES are in. - (define (find-deps dep-name elf-files) - (map dirname (filter (lambda (file) - (string=? dep-name (basename file))) - elf-files))) - - ;; Return a list of libraries that FILE needs. - (define (file-needed file) - (let* ((elf (call-with-input-file file - (compose parse-elf get-bytevector-all))) - (dyninfo (elf-dynamic-info elf))) - (if dyninfo - (elf-dynamic-info-needed dyninfo) - '()))) - - - ;; If FILE needs any libs that are part of ELF-FILES, the RUNPATH - ;; is modified accordingly. - (define (handle-file file elf-files) - (let* ((dep-dirs (concatenate (map (lambda (dep-name) - (find-deps dep-name elf-files)) - (file-needed file))))) - (unless (null? dep-dirs) - (augment-rpath file (string-join dep-dirs ":"))))) - (define handle-output (match-lambda ((output . directory) @@ -129,10 +99,7 @@ for example libraries only needed for the tests." (elf-list (concatenate (map (lambda (dir) (find-files dir elf-pred)) existing-elf-dirs)))) - (for-each (lambda (elf-file) - (invoke "patchelf" "--shrink-rpath" elf-file) - (handle-file elf-file elf-list)) - elf-list))))) + (for-each strip-runpath elf-list))))) (for-each handle-output outputs) #t) @@ -144,13 +111,8 @@ for example libraries only needed for the tests." (replace 'configure configure) (replace 'build build) (replace 'check check) - ;; XXX: We used to have 'fix-runpath' here, but it appears no longer - ;; necessary with newer Meson. However on 'core-updates' there is a - ;; useful 'strip-runpath' procedure to ensure no bogus directories in - ;; RUNPATH (remember that we tell Meson to not touch RUNPATH in - ;; (@ (gnu packages build-tools) meson-for-build)), so it should be - ;; re-added there sans the augment-rpath calls (which are not needed). - (replace 'install install))) + (replace 'install install) + (add-after 'strip 'shrink-runpath shrink-runpath))) (define* (meson-build #:key inputs phases #:allow-other-keys #:rest args) diff --git a/guix/build/ocaml-build-system.scm b/guix/build/ocaml-build-system.scm index d10431d8ef..99111ad300 100644 --- a/guix/build/ocaml-build-system.scm +++ b/guix/build/ocaml-build-system.scm @@ -49,37 +49,40 @@ '()) ,@configure-flags))) (format #t "running 'setup.ml' with arguments ~s~%" args) - (zero? (apply system* "ocaml" "setup.ml" args))) + (apply invoke "ocaml" "setup.ml" args)) (let ((args `("-prefix" ,out ,@configure-flags))) (format #t "running 'configure' with arguments ~s~%" args) - (zero? (apply system* "./configure" args)))))) + (apply invoke "./configure" args)))) + #t) (define* (build #:key inputs outputs (build-flags '()) (make-flags '()) (use-make? #f) #:allow-other-keys) "Build the given package." (if (and (file-exists? "setup.ml") (not use-make?)) - (zero? (apply system* "ocaml" "setup.ml" "-build" build-flags)) + (apply invoke "ocaml" "setup.ml" "-build" build-flags) (if (file-exists? "Makefile") - (zero? (apply system* "make" make-flags)) + (apply invoke "make" make-flags) (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml"))) - (zero? (apply system* "ocaml" "-I" - (string-append (assoc-ref inputs "findlib") - "/lib/ocaml/site-lib") - file build-flags)))))) + (apply invoke "ocaml" "-I" + (string-append (assoc-ref inputs "findlib") + "/lib/ocaml/site-lib") + file build-flags)))) + #t) (define* (check #:key inputs outputs (make-flags '()) (test-target "test") tests? (use-make? #f) #:allow-other-keys) "Install the given package." (when tests? (if (and (file-exists? "setup.ml") (not use-make?)) - (zero? (system* "ocaml" "setup.ml" (string-append "-" test-target))) + (invoke "ocaml" "setup.ml" (string-append "-" test-target)) (if (file-exists? "Makefile") - (zero? (apply system* "make" test-target make-flags)) + (apply invoke "make" test-target make-flags) (let ((file (if (file-exists? "pkg/pkg.ml") "pkg/pkg.ml" "pkg/build.ml"))) - (zero? (system* "ocaml" "-I" - (string-append (assoc-ref inputs "findlib") - "/lib/ocaml/site-lib") - file test-target))))))) + (invoke "ocaml" "-I" + (string-append (assoc-ref inputs "findlib") + "/lib/ocaml/site-lib") + file test-target))))) + #t) (define* (install #:key outputs (build-flags '()) (make-flags '()) (use-make? #f) (install-target "install") @@ -87,17 +90,19 @@ "Install the given package." (let ((out (assoc-ref outputs "out"))) (if (and (file-exists? "setup.ml") (not use-make?)) - (zero? (apply system* "ocaml" "setup.ml" - (string-append "-" install-target) build-flags)) + (apply invoke "ocaml" "setup.ml" + (string-append "-" install-target) build-flags) (if (file-exists? "Makefile") - (zero? (apply system* "make" install-target make-flags)) - (zero? (system* "opam-installer" "-i" (string-append "--prefix=" out) - (string-append "--libdir=" out "/lib/ocaml/site-lib"))))))) + (apply invoke "make" install-target make-flags) + (invoke "opam-installer" "-i" (string-append "--prefix=" out) + (string-append "--libdir=" out "/lib/ocaml/site-lib"))))) + #t) (define* (prepare-install #:key outputs #:allow-other-keys) "Prepare for building the given package." (mkdir-p (string-append (assoc-ref outputs "out") "/lib/ocaml/site-lib")) - (mkdir-p (string-append (assoc-ref outputs "out") "/bin"))) + (mkdir-p (string-append (assoc-ref outputs "out") "/bin")) + #t) (define %standard-phases ;; Everything is as with the GNU Build System except for the `configure' diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index df785c85a7..0c23cd300e 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -94,12 +94,20 @@ definitions for all the SEARCH-PATHS." (for-each (write-environment-variable-definition port) (map (abstract-profile output) variables)))))) -(define (ensure-writable-directory directory) +(define* (ensure-writable-directory directory + #:key (symlink symlink)) "Ensure DIRECTORY exists and is writable. If DIRECTORY is currently a symlink (to a read-only directory in the store), then delete the symlink and instead make DIRECTORY a \"real\" directory containing symlinks." + (define (absolute? file) + (string-prefix? "/" file)) + (define (unsymlink link) - (let* ((target (readlink link)) + (let* ((target (match (readlink link) + ((? absolute? target) + target) + ((? string? relative) + (string-append (dirname link) "/" relative)))) ;; TARGET might itself be a symlink, so append "/" to make sure ;; 'scandir' enters it. (files (scandir (string-append target "/") @@ -149,7 +157,8 @@ SEARCH-PATHS." ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have ;; made 'etc' a symlink to a read-only sub-directory in the store so we need ;; to work around that. - (ensure-writable-directory (string-append output "/etc")) + (ensure-writable-directory (string-append output "/etc") + #:symlink symlink) ;; Write 'OUTPUT/etc/profile'. (build-etc/profile output search-paths)) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index 376ea81f1a..5bb0ba49d5 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -246,8 +246,6 @@ installed with setuptools." (define* (enable-bytecode-determinism #:rest _) "Improve determinism of pyc files." - ;; Set DETERMINISTIC_BUILD to override the embedded mtime in pyc files. - (setenv "DETERMINISTIC_BUILD" "1") ;; Use deterministic hashes for strings, bytes, and datetime objects. (setenv "PYTHONHASHSEED" "0") #t) diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 4d8ac5b479..2c0b322da9 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -44,7 +44,7 @@ (unless (zero? code) (raise (condition ((@@ (guix build utils) &invoke-error) (program "R") - (arguments (string-append params " " command)) + (arguments (cons command params)) (exit-status (status:exit-val code)) (term-signal (status:term-sig code)) (stop-signal (status:stop-sig code))))))))) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 2d9590d16f..549aa4f28b 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -19,6 +19,7 @@ (define-module (guix build store-copy) #:use-module (guix build utils) #:use-module (guix sets) + #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -167,7 +168,30 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) -(define* (populate-store reference-graphs target) +(define (reset-permissions file) + "Reset the permissions on FILE and its sub-directories so that they are all +read-only." + ;; XXX: This procedure exists just to work around the inability of + ;; 'copy-recursively' to preserve permissions. + (file-system-fold (const #t) ;enter? + (lambda (file stat _) ;leaf + (unless (eq? 'symlink (stat:type stat)) + (chmod file + (if (zero? (logand (stat:mode stat) + #o100)) + #o444 + #o555)))) + (const #t) ;down + (lambda (directory stat _) ;up + (chmod directory #o555)) + (const #f) ;skip + (const #f) ;error + #t + file + lstat)) + +(define* (populate-store reference-graphs target + #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in REFERENCE-GRAPHS, a list of reference-graph files." (define store @@ -183,9 +207,26 @@ REFERENCE-GRAPHS, a list of reference-graph files." (mkdir-p store) (chmod store #o1775) - (for-each (lambda (thing) - (copy-recursively thing - (string-append target thing))) - (things-to-copy))) + + (let* ((things (things-to-copy)) + (len (length things)) + (progress (progress-reporter/bar len + (format #f "copying ~a store items" + len) + log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (thing) + (copy-recursively thing + (string-append target thing) + #:keep-mtime? #t + #:log (%make-void-port "w")) + + ;; XXX: Since 'copy-recursively' doesn't allow us to + ;; preserve permissions, we have to traverse TARGET to + ;; make sure everything is read-only. + (reset-permissions (string-append target thing)) + (report)) + things))))) ;;; store-copy.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 74cb675fcf..56a689f667 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -385,8 +385,8 @@ the returned procedure is called." #:return-errno? #t))) (lambda args (lambda _ - (error (format #f "~a: syscall->procedure failed: ~s" - name args)))))) + (throw 'system-error name "~A" (list (strerror ENOSYS)) + (list ENOSYS)))))) (define-syntax define-as-needed (syntax-rules () diff --git a/guix/build/utils.scm b/guix/build/utils.scm index c58a1afd1c..5fe3286843 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1057,11 +1057,11 @@ with definitions for VARS." (format #f "export ~a=\"~a\"" var (string-join rest sep))) ((var sep 'prefix rest) - (format #f "export ~a=\"~a${~a~a+~a}$~a\"" - var (string-join rest sep) var sep sep var)) + (format #f "export ~a=\"~a${~a:+~a}$~a\"" + var (string-join rest sep) var sep var)) ((var sep 'suffix rest) - (format #f "export ~a=\"$~a${~a~a+~a}~a\"" - var var var sep sep (string-join rest sep))) + (format #f "export ~a=\"$~a${~a+~a}~a\"" + var var var sep (string-join rest sep))) ((var '= rest) (format #f "export ~a=\"~a\"" var (string-join rest ":"))) diff --git a/guix/channels.scm b/guix/channels.scm new file mode 100644 index 0000000000..e57da68149 --- /dev/null +++ b/guix/channels.scm @@ -0,0 +1,322 @@ +;;; GNU Guix --- Functional package management for GNU +;;; 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 channels) + #:use-module (guix git) + #:use-module (guix records) + #:use-module (guix gexp) + #:use-module (guix discovery) + #:use-module (guix monads) + #:use-module (guix profiles) + #:use-module (guix derivations) + #:use-module (guix store) + #:use-module (guix i18n) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:autoload (guix self) (whole-package) + #:use-module (ice-9 match) + #:export (channel + channel? + channel-name + channel-url + channel-branch + channel-commit + channel-location + + %default-channels + + channel-instance? + channel-instance-channel + channel-instance-commit + channel-instance-checkout + + latest-channel-instances + checkout->channel-instance + latest-channel-derivation + channel-instances->manifest + channel-instances->derivation)) + +;;; Commentary: +;;; +;;; This module implements "channels." A channel is usually a source of +;;; package definitions. There's a special channel, the 'guix' channel, that +;;; provides all of Guix, including its commands and its documentation. +;;; User-defined channels are expected to typically provide a bunch of .scm +;;; files meant to be added to the '%package-search-path'. +;;; +;;; This module provides tools to fetch and update channels from a Git +;;; repository and to build them. +;;; +;;; Code: + +(define-record-type* <channel> channel make-channel + channel? + (name channel-name) + (url channel-url) + (branch channel-branch (default "master")) + (commit channel-commit (default #f)) + (location channel-location + (default (current-source-location)) (innate))) +;; TODO: Add a way to express dependencies among channels. + +(define %default-channels + ;; Default list of channels. + (list (channel + (name 'guix) + (branch "master") + (url "https://git.savannah.gnu.org/git/guix.git")))) + +(define (guix-channel? channel) + "Return true if CHANNEL is the 'guix' channel." + (eq? 'guix (channel-name channel))) + +(define-record-type <channel-instance> + (channel-instance channel commit checkout) + channel-instance? + (channel channel-instance-channel) + (commit channel-instance-commit) + (checkout channel-instance-checkout)) + +(define (channel-reference channel) + "Return the \"reference\" for CHANNEL, an sexp suitable for +'latest-repository-commit'." + (match (channel-commit channel) + (#f `(branch . ,(channel-branch channel))) + (commit `(commit . ,(channel-commit channel))))) + +(define (latest-channel-instances store channels) + "Return a list of channel instances corresponding to the latest checkouts of +CHANNELS." + (map (lambda (channel) + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let-values (((checkout commit) + (latest-repository-commit store (channel-url channel) + #:ref (channel-reference + channel)))) + (channel-instance channel commit checkout))) + channels)) + +(define* (checkout->channel-instance checkout + #:key commit + (url checkout) (name 'guix)) + "Return a channel instance for CHECKOUT, which is assumed to be a checkout +of COMMIT at URL. Use NAME as the channel name." + (let* ((commit (or commit (make-string 40 #\0))) + (channel (channel (name name) + (commit commit) + (url url)))) + (channel-instance channel commit checkout))) + +(define %self-build-file + ;; The file containing code to build Guix. This serves the same purpose as + ;; a makefile, and, similarly, is intended to always keep this name. + "build-aux/build-self.scm") + +(define %pull-version + ;; This is the version of the 'guix pull' protocol. It specifies what's + ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd + ;; place a set of compiled Guile modules in ~/.config/guix/latest. + 1) + +(define (standard-module-derivation name source dependencies) + "Return a derivation that builds the Scheme modules in SOURCE and that +depend on DEPENDENCIES, a list of lowerable objects. The assumption is that +SOURCE contains package modules to be added to '%package-module-path'." + (define modules + (scheme-modules* source)) + + ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow + ;; channel publishers to specify things such as the sub-directory where .scm + ;; files live, files to exclude from the channel, preferred substitute URLs, + ;; etc. + (mlet* %store-monad ((compiled + (compiled-modules modules + #:name name + #:module-path (list source) + #:extensions dependencies))) + + (gexp->derivation name + (with-extensions dependencies + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (let ((go (string-append #$output "/lib/guile/" + (effective-version) + "/site-ccache")) + (scm (string-append #$output + "/share/guile/site/" + (effective-version)))) + (mkdir-p (dirname go)) + (symlink #$compiled go) + (mkdir-p (dirname scm)) + (symlink #$source scm)))))))) + +(define* (build-from-source name source + #:key verbose? commit + (dependencies '())) + "Return a derivation to build Guix from SOURCE, using the self-build script +contained therein. Use COMMIT as the version string." + ;; Running the self-build script makes it easier to update the build + ;; procedure: the self-build script of the Guix-to-be-installed contains the + ;; right dependencies, build procedure, etc., which the Guix-in-use may not + ;; be know. + (define script + (string-append source "/" %self-build-file)) + + (if (file-exists? script) + (let ((build (save-module-excursion + (lambda () + (primitive-load script))))) + ;; BUILD must be a monadic procedure of at least one argument: the + ;; source tree. + ;; + ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In + ;; the future we'll fall back to a previous version of the protocol + ;; when that happens. + (build source #:verbose? verbose? #:version commit + #:pull-version %pull-version)) + + ;; Build a set of modules that extend Guix using the standard method. + (standard-module-derivation name source dependencies))) + +(define* (build-channel-instance instance #:optional (dependencies '())) + "Return, as a monadic value, the derivation for INSTANCE, a channel +instance. DEPENDENCIES is a list of extensions providing Guile modules that +INSTANCE depends on." + (build-from-source (symbol->string + (channel-name (channel-instance-channel instance))) + (channel-instance-checkout instance) + #:commit (channel-instance-commit instance) + #:dependencies dependencies)) + +(define (channel-instance-derivations instances) + "Return the list of derivations to build INSTANCES, in the same order as +INSTANCES." + (define core-instance + ;; The 'guix' channel is treated specially: it's an implicit dependency of + ;; all the other channels. + (find (lambda (instance) + (guix-channel? (channel-instance-channel instance))) + instances)) + + (define dependencies + ;; Dependencies of CORE-INSTANCE. + ;; FIXME: It would be best not to hard-wire this information here and + ;; instead query it to CORE-INSTANCE. + (list (module-ref (resolve-interface '(gnu packages gnupg)) + 'guile-gcrypt) + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-git) + (module-ref (resolve-interface '(gnu packages guile)) + 'guile-bytestructures))) + + (mlet %store-monad ((core (build-channel-instance core-instance))) + (mapm %store-monad + (lambda (instance) + (if (eq? instance core-instance) + (return core) + (build-channel-instance instance + (cons core dependencies)))) + instances))) + +(define (whole-package-for-legacy name modules) + "Return a full-blown Guix package for MODULES, a derivation that builds Guix +modules in the old ~/.config/guix/latest style." + (define packages + (resolve-interface '(gnu packages guile))) + + (letrec-syntax ((list (syntax-rules (->) + ((_) + '()) + ((_ (module -> variable) rest ...) + (cons (module-ref (resolve-interface + '(gnu packages module)) + 'variable) + (list rest ...))) + ((_ variable rest ...) + (cons (module-ref packages 'variable) + (list rest ...)))))) + (whole-package name modules + + ;; In the "old style", %SELF-BUILD-FILE would simply return a + ;; derivation that builds modules. We have to infer what the + ;; dependencies of these modules were. + (list guile-json guile-git guile-bytestructures + (ssh -> guile-ssh) (tls -> gnutls))))) + +(define (old-style-guix? drv) + "Return true if DRV corresponds to a ~/.config/guix/latest style of +derivation." + ;; Here we rely on a gross historical fact: that derivations produced by the + ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8, + ;; dated May 30, 2018) did not depend on "guix-command.drv". + (not (find (lambda (input) + (string-suffix? "-guix-command.drv" + (derivation-input-path input))) + (derivation-inputs drv)))) + +(define (channel-instances->manifest instances) + "Return a profile manifest with entries for all of INSTANCES, a list of +channel instances." + (define instance->entry + (match-lambda + ((instance drv) + (let ((commit (channel-instance-commit instance)) + (channel (channel-instance-channel instance))) + (with-monad %store-monad + (return (manifest-entry + (name (symbol->string (channel-name channel))) + (version (string-take commit 7)) + (item (if (guix-channel? channel) + (if (old-style-guix? drv) + (whole-package-for-legacy + (string-append name "-" version) + drv) + drv) + drv)) + (properties + `((source (repository + (version 0) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,commit)))))))))))) + + (mlet* %store-monad ((derivations (channel-instance-derivations instances)) + (entries (mapm %store-monad instance->entry + (zip instances derivations)))) + (return (manifest entries)))) + +(define (channel-instances->derivation instances) + "Return the derivation of the profile containing INSTANCES, a list of +channel instances." + (mlet %store-monad ((manifest (channel-instances->manifest instances))) + (profile-derivation manifest))) + +(define latest-channel-instances* + (store-lift latest-channel-instances)) + +(define* (latest-channel-derivation #:optional (channels %default-channels)) + "Return as a monadic value the derivation that builds the profile for the +latest instances of CHANNELS." + (mlet %store-monad ((instances (latest-channel-instances* channels))) + (channel-instances->derivation instances))) diff --git a/guix/ci.scm b/guix/ci.scm index 881f3d3927..1727297dd7 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -19,6 +19,7 @@ (define-module (guix ci) #:use-module (guix http-client) #:autoload (json parser) (json->scm) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:export (build? build-id @@ -27,9 +28,21 @@ build-status build-timestamp + checkout? + checkout-commit + checkout-input + + evaluation? + evaluation-id + evaluation-spec + evaluation-complete? + evaluation-checkouts + %query-limit queued-builds - latest-builds)) + latest-builds + latest-evaluations + evaluation-for-commit)) ;;; Commentary: ;;; @@ -47,6 +60,20 @@ (status build-status) ;integer (timestamp build-timestamp)) ;integer +(define-record-type <checkout> + (make-checkout commit input) + checkout? + (commit checkout-commit) ;string (SHA1) + (input checkout-input)) ;string (name) + +(define-record-type <evaluation> + (make-evaluation id spec complete? checkouts) + evaluation? + (id evaluation-id) ;integer + (spec evaluation-spec) ;string + (complete? evaluation-complete?) ;Boolean + (checkouts evaluation-checkouts)) ;<checkout>* + (define %query-limit ;; Max number of builds requested in queries. 1000) @@ -70,9 +97,50 @@ (number->string limit))))) (map json->build queue))) -(define* (latest-builds url #:optional (limit %query-limit)) +(define* (latest-builds url #:optional (limit %query-limit) + #:key evaluation system) + "Return the latest builds performed by the CI server at URL. If EVALUATION +is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system +string such as \"x86_64-linux\"), restrict to builds for SYSTEM." + (define* (option name value #:optional (->string identity)) + (if value + (string-append "&" name "=" (->string value)) + "")) + (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr=" - (number->string limit))))) + (number->string limit) + (option "evaluation" evaluation + number->string) + (option "system" system))))) ;; Note: Hydra does not provide a "derivation" field for entries in ;; 'latestbuilds', but Cuirass does. (map json->build latest))) + +(define (json->checkout json) + (make-checkout (hash-ref json "commit") + (hash-ref json "input"))) + +(define (json->evaluation json) + (make-evaluation (hash-ref json "id") + (hash-ref json "specification") + (case (hash-ref json "in-progress") + ((0) #t) + (else #f)) + (map json->checkout (hash-ref json "checkouts")))) + +(define* (latest-evaluations url #:optional (limit %query-limit)) + "Return the latest evaluations performed by the CI server at URL." + (map json->evaluation + (json->scm + (http-fetch (string-append url "/api/evaluations?nr=" + (number->string limit)))))) + + +(define* (evaluations-for-commit url commit #:optional (limit %query-limit)) + "Return the evaluations among the latest LIMIT evaluations that have COMMIT +as one of their inputs." + (filter (lambda (evaluation) + (find (lambda (checkout) + (string=? (checkout-commit checkout) commit)) + (evaluation-checkouts evaluation))) + (latest-evaluations url limit))) diff --git a/guix/cve.scm b/guix/cve.scm index 070acfeb3e..99754fa1f6 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,7 +61,7 @@ (define (yearly-feed-uri year) "Return the URI for the CVE feed for YEAR." (string->uri - (string-append "https://static.nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-" + (string-append "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-" (number->string year) ".xml.gz"))) (define %current-year-ttl diff --git a/guix/derivations.scm b/guix/derivations.scm index da686e89e2..f6176a78fd 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -35,7 +35,7 @@ #:use-module (guix memoization) #:use-module (guix combinators) #:use-module (guix monads) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix records) #:use-module (guix sets) @@ -80,6 +80,7 @@ substitutable-derivation? substitution-oracle derivation-hash + derivation-properties read-derivation read-derivation-from-file @@ -681,7 +682,8 @@ name of each input with that input's hash." references-graphs allowed-references disallowed-references leaked-env-vars local-build? - (substitutable? #t)) + (substitutable? #t) + (properties '())) "Build a derivation with the given arguments, and return the resulting <derivation> object. When HASH and HASH-ALGO are given, a fixed-output derivation is created---i.e., one whose result is known in @@ -708,7 +710,10 @@ for offloading and should rather be built locally. This is the case for small derivations where the costs of data transfers would outweigh the benefits. When SUBSTITUTABLE? is false, declare that substitutes of the derivation's -output should not be used." +output should not be used. + +PROPERTIES must be an association list describing \"properties\" of the +derivation. It is kept as-is, uninterpreted, in the derivation." (define (add-output-paths drv) ;; Return DRV with an actual store path for each of its output and the ;; corresponding environment variable. @@ -763,6 +768,10 @@ output should not be used." `(("impureEnvVars" . ,(string-join leaked-env-vars))) '()) + ,@(match properties + (() '()) + (lst `(("guix properties" + . ,(object->string properties))))) ,@env-vars))) (match references-graphs (((file . path) ...) @@ -851,6 +860,14 @@ long-running processes that know what they're doing. Use with care!" (invalidate-memoization! derivation-path->base16-hash) (hash-clear! %derivation-cache)) +(define derivation-properties + (mlambdaq (drv) + "Return the property alist associated with DRV." + (match (assoc "guix properties" + (derivation-builder-environment-vars drv)) + ((_ . str) (call-with-input-string str read)) + (#f '())))) + (define* (map-derivation store drv mapping #:key (system (%current-system))) "Given MAPPING, a list of pairs of derivations, return a derivation based on @@ -1129,7 +1146,8 @@ they can refer to each other." references-graphs allowed-references disallowed-references - local-build? (substitutable? #t)) + local-build? (substitutable? #t) + (properties '())) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list @@ -1149,7 +1167,8 @@ EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is omitted or is #f, the value of the `%guile-for-build' fluid is used instead. See the `derivation' procedure for the meaning of REFERENCES-GRAPHS, -ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." +ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, SUBSTITUTABLE?, +and PROPERTIES." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1277,7 +1296,8 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." #:allowed-references allowed-references #:disallowed-references disallowed-references #:local-build? local-build? - #:substitutable? substitutable?))) + #:substitutable? substitutable? + #:properties properties))) ;;; diff --git a/guix/describe.scm b/guix/describe.scm new file mode 100644 index 0000000000..670db63ce7 --- /dev/null +++ b/guix/describe.scm @@ -0,0 +1,75 @@ +;;; GNU Guix --- Functional package management for GNU +;;; 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 describe) + #:use-module (guix memoization) + #:use-module (guix profiles) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (current-profile + current-profile-entries + package-path-entries)) + +;;; Commentary: +;;; +;;; This module provides supporting code to allow a Guix instance to find, at +;;; run time, which profile it's in (profiles created by 'guix pull'). That +;;; allows it to read meta-information about itself (e.g., repository URL and +;;; commit ID) and to find other channels available in the same profile. It's +;;; a bit like ELPA's pkg-info.el. +;;; +;;; Code: + +(define current-profile + (mlambda () + "Return the profile (created by 'guix pull') the calling process lives in, +or #f if this is not applicable." + (match (command-line) + ((program . _) + (and (string-suffix? "/bin/guix" program) + ;; Note: We want to do _lexical dot-dot resolution_. Using ".." + ;; for real would instead take us into the /gnu/store directory + ;; that ~/.config/guix/current/bin points to, whereas we want to + ;; obtain ~/.config/guix/current. + (let ((candidate (dirname (dirname program)))) + (and (file-exists? (string-append candidate "/manifest")) + candidate))))))) + +(define current-profile-entries + (mlambda () + "Return the list of entries in the 'guix pull' profile the calling process +lives in, or #f if this is not applicable." + (match (current-profile) + (#f '()) + (profile + (let ((manifest (profile-manifest profile))) + (manifest-entries manifest)))))) + +(define package-path-entries + (mlambda () + "Return a list of package path entries to be added to the package search +path. These entries are taken from the 'guix pull' profile the calling +process lives in, when applicable." + ;; Filter out Guix itself. + (filter-map (lambda (entry) + (and (not (string=? (manifest-entry-name entry) + "guix")) + (string-append (manifest-entry-item entry) + "/share/guile/site/" + (effective-version)))) + (current-profile-entries)))) diff --git a/guix/discovery.scm b/guix/discovery.scm index 2b627d108e..3fc6e2c9e7 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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. ;;; @@ -27,6 +27,7 @@ #:use-module (ice-9 ftw) #:export (scheme-files scheme-modules + scheme-modules* fold-modules all-modules fold-module-public-variables)) @@ -115,6 +116,16 @@ name and the exception key and arguments." (string-append directory "/" sub-directory) directory)))) +(define* (scheme-modules* directory #:optional sub-directory) + "Return the list of module names found under SUB-DIRECTORY in DIRECTORY. +This is a source-only variant that does not try to load files." + (let ((prefix (string-length directory))) + (map (lambda (file) + (file-name->module-name (string-drop file prefix))) + (scheme-files (if sub-directory + (string-append directory "/" sub-directory) + directory))))) + (define* (fold-modules proc init path #:key (warn (const #f))) "Fold over all the Scheme modules present in PATH, a list of directories. Call (PROC MODULE RESULT) for each module that is found." diff --git a/guix/docker.scm b/guix/docker.scm index b869901599..c6e9c6fee5 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -19,13 +19,14 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix docker) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base16) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively with-directory-excursion invoke)) + #:use-module (gnu build install) #:use-module (json) ;guile-json #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -108,11 +109,15 @@ return \"a\"." (symlinks '()) (transformations '()) (system (utsname:machine (uname))) + database compressor (creation-time (current-time time-utc))) "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX must be a store path that is a prefix of any store paths in PATHS. +When DATABASE is true, copy it to /var/guix/db in the image and create +/var/guix/gcroots and friends. + SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be created in the image, where each TARGET is relative to PREFIX. TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to @@ -188,10 +193,15 @@ SRFI-19 time-utc object, as the creation time in metadata." source)))) symlinks) + (when database + ;; Initialize /var/guix, assuming PREFIX points to a profile. + (install-database-and-gc-roots "." database prefix)) + (apply invoke "tar" "-cf" "layer.tar" `(,@transformation-options ,@%tar-determinism-options ,@paths + ,@(if database '("var") '()) ,@(map symlink-source symlinks))) ;; It is possible for "/" to show up in the archive, especially when ;; applying transformations. For example, the transformation @@ -199,11 +209,20 @@ SRFI-19 time-utc object, as the creation time in metadata." ;; the path "/a" into "/". The presence of "/" in the archive is ;; probably benign, but it is definitely safe to remove it, so let's ;; do that. This fails when "/" is not in the archive, so use system* - ;; instead of invoke to avoid an exception in that case. - (system* "tar" "--delete" "/" "-f" "layer.tar") + ;; instead of invoke to avoid an exception in that case, and redirect + ;; stderr to the bit bucket to avoid "Exiting with failure status" + ;; error messages. + (with-error-to-port (%make-void-port "w") + (lambda () + (system* "tar" "--delete" "/" "-f" "layer.tar"))) + (for-each delete-file-recursively (map (compose topmost-component symlink-source) - symlinks))) + symlinks)) + + ;; Delete /var/guix. + (when database + (delete-file-recursively "var"))) (with-output-to-file "config.json" (lambda () diff --git a/guix/download.scm b/guix/download.scm index 988117885c..a7f51b1999 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -372,19 +372,38 @@ ;; List of content-addressed mirrors. Each mirror is represented as a ;; procedure that takes a file name, an algorithm (symbol) and a hash ;; (bytevector), and returns a URL or #f. - ;; Note: Avoid 'https' to mitigate <http://bugs.gnu.org/22774>. - ;; TODO: Add more. - '(list (lambda (file algo hash) - ;; Files served by 'guix publish' are accessible under a single - ;; hash algorithm. - (string-append "http://mirror.hydra.gnu.org/file/" - file "/" (symbol->string algo) "/" - (bytevector->nix-base32-string hash))) - (lambda (file algo hash) - ;; 'tarballs.nixos.org' supports several algorithms. - (string-append "http://tarballs.nixos.org/" - (symbol->string algo) "/" - (bytevector->nix-base32-string hash))))) + '(begin + (use-modules (guix base32)) + + (define (guix-publish host) + (lambda (file algo hash) + ;; Files served by 'guix publish' are accessible under a single + ;; hash algorithm. + (string-append "https://" host "/file/" + file "/" (symbol->string algo) "/" + (bytevector->nix-base32-string hash)))) + + ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old + ;; installations of the daemon might lack it. Thus, load it lazily to + ;; avoid gratuitous errors. See <https://bugs.gnu.org/33542>. + (module-autoload! (current-module) + '(guix base16) '(bytevector->base16-string)) + + (list (guix-publish "mirror.hydra.gnu.org") + (guix-publish "berlin.guixsd.org") + (lambda (file algo hash) + ;; 'tarballs.nixos.org' supports several algorithms. + (string-append "https://tarballs.nixos.org/" + (symbol->string algo) "/" + (bytevector->nix-base32-string hash))) + (lambda (file algo hash) + ;; Software Heritage usually archives VCS history rather than + ;; tarballs, but tarballs are sometimes available (and can be + ;; explicitly stored there.) For example, see + ;; <https://archive.softwareheritage.org/api/1/content/sha256:92d0fa1c311cacefa89853bdb53c62f4110cdfda3820346b59cbd098f40f955e/>. + (string-append "https://archive.softwareheritage.org/api/1/content/" + (symbol->string algo) ":" + (bytevector->base16-string hash) "/raw/"))))) (define %content-addressed-mirror-file ;; Content-addressed mirrors stored in a file. diff --git a/guix/gcrypt.scm b/guix/gcrypt.scm deleted file mode 100644 index 1517501751..0000000000 --- a/guix/gcrypt.scm +++ /dev/null @@ -1,49 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 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 gcrypt) - #:use-module (guix config) - #:use-module (system foreign) - #:export (gcrypt-version - libgcrypt-func)) - -;;; Commentary: -;;; -;;; Common code for the GNU Libgcrypt bindings. Loading this module -;;; initializes Libgcrypt as a side effect. -;;; -;;; Code: - -(define libgcrypt-func - (let ((lib (dynamic-link %libgcrypt))) - (lambda (func) - "Return a pointer to symbol FUNC in libgcrypt." - (dynamic-func func lib)))) - -(define gcrypt-version - ;; According to the manual, this function must be called before any other, - ;; and it's not clear whether it can be called more than once. So call it - ;; right here from the top level. - (let* ((ptr (libgcrypt-func "gcry_check_version")) - (proc (pointer->procedure '* ptr '(*))) - (version (pointer->string (proc %null-pointer)))) - (lambda () - "Return the version number of libgcrypt as a string." - version))) - -;;; gcrypt.scm ends here diff --git a/guix/gexp.scm b/guix/gexp.scm index ffc976d61b..fd3b6be348 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -211,7 +211,12 @@ OBJ must be an object that has an associated gexp compiler, such as a (#f (raise (condition (&gexp-input-error (input obj))))) (lower - (lower obj system target)))) + ;; Cache in STORE the result of lowering OBJ. + (mlet %store-monad ((graft? (grafting?))) + (mcached (let ((lower (lookup-compiler obj))) + (lower obj system target)) + obj + system target graft?))))) (define-syntax define-gexp-compiler (syntax-rules (=> compiler expander) @@ -438,6 +443,14 @@ This is the declarative counterpart of 'gexp->file'." (base file-append-base) ;<package> | <derivation> | ... (suffix file-append-suffix)) ;list of strings +(define (write-file-append file port) + (match file + (($ <file-append> base suffix) + (format port "#<file-append ~s ~s>" base + (string-join suffix))))) + +(set-record-type-printer! <file-append> write-file-append) + (define (file-append base . suffix) "Return a <file-append> object that expands to the concatenation of BASE and SUFFIX." @@ -498,9 +511,10 @@ whether this should be considered a \"native\" input or not." (set-record-type-printer! <gexp-output> write-gexp-output) -(define (gexp-attribute gexp self-attribute) +(define* (gexp-attribute gexp self-attribute #:optional (equal? equal?)) "Recurse on GEXP and the expressions it refers to, summing the items -returned by SELF-ATTRIBUTE, a procedure that takes a gexp." +returned by SELF-ATTRIBUTE, a procedure that takes a gexp. Use EQUAL? as the +second argument to 'delete-duplicates'." (if (gexp? gexp) (delete-duplicates (append (self-attribute gexp) @@ -516,13 +530,29 @@ returned by SELF-ATTRIBUTE, a procedure that takes a gexp." lst)) (_ '())) - (gexp-references gexp)))) + (gexp-references gexp))) + equal?) '())) ;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 (module=? m1 m2) + ;; Return #t when M1 equals M2. Special-case '=>' specs because their + ;; right-hand side may not be comparable with 'equal?': it's typically a + ;; file-like object that embeds a gexp, which in turn embeds closure; + ;; those closures may be 'eq?' when running compiled code but are unlikely + ;; to be 'eq?' when running on 'eval'. Ignore the right-hand side to + ;; avoid this discrepancy. + (match m1 + (((name1 ...) '=> _) + (match m2 + (((name2 ...) '=> _) (equal? name1 name2)) + (_ #f))) + (_ + (equal? m1 m2)))) + + (gexp-attribute gexp gexp-self-modules module=?)) (define (gexp-extensions gexp) "Return the list of Guile extensions (packages) GEXP relies on. If (gexp? @@ -601,11 +631,7 @@ names and file names suitable for the #:allowed-references argument to allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) - - ;; TODO: This parameter is transitional; it's here - ;; to avoid a full rebuild. Remove it on the next - ;; rebuild cycle. - import-creates-derivation? + (properties '()) deprecation-warnings (script-name (string-append name "-builder"))) @@ -701,18 +727,12 @@ The other arguments are as for 'derivation'." extensions)) (modules (if (pair? %modules) (imported-modules %modules - #:derivation? - import-creates-derivation? #:system system #:module-path module-path - #:guile guile-for-build - #:deprecation-warnings - deprecation-warnings) + #:guile guile-for-build) (return #f))) (compiled (if (pair? %modules) (compiled-modules %modules - #:derivation? - import-creates-derivation? #:system system #:module-path module-path #:extensions extensions @@ -770,7 +790,8 @@ The other arguments are as for 'derivation'." #:disallowed-references disallowed #:leaked-env-vars leaked-env-vars #:local-build? local-build? - #:substitutable? substitutable?)))) + #:substitutable? substitutable? + #:properties properties)))) (define* (gexp-inputs exp #:key native?) "Return the input list for EXP. When NATIVE? is true, return only native @@ -1080,15 +1101,7 @@ to a tree suitable for 'interned-file-tree'." #:key (name "file-import") (symlink? #f) (system (%current-system)) - (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)) + (guile (%guile-for-build))) "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, @@ -1128,54 +1141,38 @@ to the source files instead of copying them." #:guile-for-build guile #:local-build? #t - ;; TODO: On the next rebuild cycle, set to "no" - ;; unconditionally. + ;; Avoid deprecation warnings about the use of the _IO* + ;; constants in (guix build utils). #:env-vars - (case deprecation-warnings - ((#f) - '(("GUILE_WARN_DEPRECATED" . "no"))) - ((detailed) - '(("GUILE_WARN_DEPRECATED" . "detailed"))) - (else - '()))))) + '(("GUILE_WARN_DEPRECATED" . "no"))))) (define* (imported-files files #:key (name "file-import") - - ;; TODO: Remove this parameter on the next rebuild - ;; cycle. - (derivation? #f) - ;; The following parameters make sense when creating ;; an actual derivation. (system (%current-system)) - (guile (%guile-for-build)) - (deprecation-warnings #f)) + (guile (%guile-for-build))) "Import FILES into the store and return the resulting derivation or store file name (a derivation is created if and only if some elements of FILES are file-like objects and not local file names.) 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, as returned by 'local-file' for example." - (if (or derivation? - (any (match-lambda - ((_ . (? struct? source)) #t) - (_ #f)) - files)) + (if (any (match-lambda + ((_ . (? struct? source)) #t) + (_ #f)) + files) (imported-files/derivation files #:name name #:symlink? derivation? - #:system system #:guile guile - #:deprecation-warnings deprecation-warnings) + #:system system #:guile guile) (interned-file-tree `(,name directory ,@(file-mapping->tree files))))) (define* (imported-modules modules #:key (name "module-import") - (derivation? #f) ;TODO: remove on next rebuild (system (%current-system)) (guile (%guile-for-build)) - (module-path %load-path) - (deprecation-warnings #f)) + (module-path %load-path)) "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 @@ -1196,14 +1193,11 @@ last one is created from the given <scheme-file> object." (cons f (search-path* module-path f))))) modules))) (imported-files files #:name name - #:derivation? derivation? #:system system - #:guile guile - #:deprecation-warnings deprecation-warnings))) + #:guile guile))) (define* (compiled-modules modules #:key (name "module-import-compiled") - (derivation? #f) ;TODO: remove on next rebuild (system (%current-system)) (guile (%guile-for-build)) (module-path %load-path) @@ -1214,22 +1208,11 @@ 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 - #:derivation? derivation? #:system system #:guile guile #:module-path - module-path - #:deprecation-warnings - deprecation-warnings))) + module-path))) (define build (gexp (begin @@ -1268,46 +1251,34 @@ 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)))) - '())) + (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 + (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))))) - '())) + ;; Above we loaded our own (guix build utils) but now we may need to + ;; load a compile a different one. Thus, force a reload. + (let ((utils (string-append (ungexp modules) + "/guix/build/utils.scm"))) + (when (file-exists? utils) + (load utils))) (mkdir (ungexp output)) (chdir (ungexp modules)) @@ -1479,26 +1450,31 @@ denoting the target file. Here's an example: `((\"hosts\" ,(plain-file \"hosts\" \"127.0.0.1 localhost\")) (\"bashrc\" ,(plain-file \"bashrc\" - \"alias ls='ls --color'\")))) + \"alias ls='ls --color'\")) + (\"libvirt/qemu.conf\" ,(plain-file \"qemu.conf\" \"\")))) This yields an 'etc' directory containing these two files." (computed-file name - (gexp - (begin - (mkdir (ungexp output)) - (chdir (ungexp output)) - (ungexp-splicing - (map (match-lambda - ((target source) - (gexp - (begin - ;; Stat the source to abort early if it does - ;; not exist. - (stat (ungexp source)) - - (symlink (ungexp source) - (ungexp target)))))) - files)))))) + (with-imported-modules '((guix build utils)) + (gexp + (begin + (use-modules (guix build utils)) + + (mkdir (ungexp output)) + (chdir (ungexp output)) + (ungexp-splicing + (map (match-lambda + ((target source) + (gexp + (begin + ;; Stat the source to abort early if it does + ;; not exist. + (stat (ungexp source)) + + (mkdir-p (dirname (ungexp target))) + (symlink (ungexp source) + (ungexp target)))))) + files))))))) (define* (directory-union name things #:key (copy? #f) (quiet? #f) diff --git a/guix/git-download.scm b/guix/git-download.scm index 33f102bc6c..6cf267d6c8 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; @@ -19,7 +19,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix git-download) - #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) @@ -27,9 +26,8 @@ #:use-module (guix packages) #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) + #:use-module (git) #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:export (git-reference @@ -62,7 +60,7 @@ (define (git-package) "Return the default Git package." (let ((distro (resolve-interface '(gnu packages version-control)))) - (module-ref distro 'git))) + (module-ref distro 'git-minimal))) (define* (git-fetch ref hash-algo hash #:optional name @@ -76,11 +74,22 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; available so that 'git submodule' works. (if (git-reference-recursive? ref) (standard-packages) - '())) + + ;; The 'swh-download' procedure requires tar and gzip. + `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) + 'gzip)) + ("tar" ,(module-ref (resolve-interface '(gnu packages base)) + 'tar))))) (define zlib (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + (define guile-json + (module-ref (resolve-interface '(gnu packages guile)) 'guile-json)) + + (define gnutls + (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) + (define config.scm (scheme-file "config.scm" #~(begin @@ -95,30 +104,43 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (delete '(guix config) (source-module-closure '((guix build git) (guix build utils) - (guix build download-nar)))))) + (guix build download-nar) + (guix swh)))))) (define build (with-imported-modules modules - #~(begin - (use-modules (guix build git) - (guix build utils) - (guix build download-nar) - (ice-9 match)) - - ;; The 'git submodule' commands expects Coreutils, sed, - ;; grep, etc. to be in $PATH. - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs outputs ...) ...) - dirs))) - - (or (git-fetch (getenv "git url") (getenv "git commit") - #$output - #:recursive? (call-with-input-string - (getenv "git recursive?") - read) - #:git-command (string-append #+git "/bin/git")) - (download-nar #$output))))) + (with-extensions (list guile-json gnutls) ;for (guix swh) + #~(begin + (use-modules (guix build git) + (guix build utils) + (guix build download-nar) + (guix swh) + (ice-9 match)) + + (define recursive? + (call-with-input-string (getenv "git recursive?") read)) + + ;; The 'git submodule' commands expects Coreutils, sed, + ;; grep, etc. to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (or (git-fetch (getenv "git url") (getenv "git commit") + #$output + #:recursive? recursive? + #:git-command (string-append #+git "/bin/git")) + (download-nar #$output) + + ;; As a last resort, attempt to download from Software Heritage. + ;; XXX: Currently recursive checkouts are not supported. + (and (not recursive?) + (swh-download (getenv "git url") (getenv "git commit") + #$output))))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build @@ -153,85 +175,57 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;;; 'git-predicate'. ;;; -(define (files->directory-tree files) - "Return a tree of vhashes representing the directory listed in FILES, a list -like '(\"a/b\" \"b/c/d\")." - (fold (lambda (file result) - (let loop ((file (string-split file #\/)) - (result result)) - (match file - ((_) - result) - ((directory children ...) - (match (vhash-assoc directory result) - (#f - (vhash-cons directory (loop children vlist-null) - result)) - ((_ . previous) - ;; XXX: 'vhash-delete' is O(n). - (vhash-cons directory (loop children previous) - (vhash-delete directory result))))) - (() - result)))) - vlist-null - files)) - -(define (directory-in-tree? tree directory) - "Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed -in TREE." - (let loop ((directory (string-split directory #\/)) - (tree tree)) - (match directory - (() - #t) - ((head . tail) - (match (vhash-assoc head tree) - ((_ . sub-tree) (loop tail sub-tree)) - (#f #f)))))) +(define (git-file-list directory) + "Return the list of files checked in in the Git repository at DIRECTORY. +The result is similar to that of the 'git ls-files' command, except that it +also includes directories, not just regular files. The returned file names +are relative to DIRECTORY, which is not necessarily the root of the checkout." + (let* (;; 'repository-working-directory' always returns a trailing "/", + ;; so add one here to ease the comparisons below. + (directory (string-append (canonicalize-path directory) "/")) + (dot-git (repository-discover directory)) + (repository (repository-open dot-git)) + ;; XXX: This procedure is mistakenly private in Guile-Git 0.1.0. + (workdir ((@@ (git repository) repository-working-directory) + repository)) + (head (repository-head repository)) + (oid (reference-target head)) + (commit (commit-lookup repository oid)) + (tree (commit-tree commit)) + (files (tree-list tree))) + (repository-close! repository) + (if (string=? workdir directory) + files + (let ((relative (string-drop directory (string-length workdir)))) + (filter-map (lambda (file) + (and (string-prefix? relative file) + (string-drop file (string-length relative)))) + files))))) (define (git-predicate directory) "Return a predicate that returns true if a file is part of the Git checkout -living at DIRECTORY. Upon Git failure, return #f instead of a predicate. +living at DIRECTORY. If DIRECTORY does not lie within a Git checkout, and +upon Git errors, return #f instead of a predicate. The returned predicate takes two arguments FILE and STAT where FILE is an absolute file name and STAT is the result of 'lstat'." - (let* ((pipe (with-directory-excursion directory - (open-pipe* OPEN_READ "git" "ls-files"))) - (files (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (reverse lines)) - (line - (loop (cons line lines)))))) - (directory-tree (files->directory-tree files)) - (inodes (fold (lambda (file result) - (let ((stat - (lstat (string-append directory "/" - file)))) - (vhash-consv (stat:ino stat) (stat:dev stat) - result))) - vlist-null - files)) - - ;; Note: For this to work we must *not* call 'canonicalize-path' on - ;; DIRECTORY or we would get discrepancies of the returned lambda is - ;; called with a non-canonical file name. - (prefix-length (+ 1 (string-length directory))) - - (status (close-pipe pipe))) - (and (zero? status) - (lambda (file stat) - (match (stat:type stat) - ('directory - (directory-in-tree? directory-tree - (string-drop file prefix-length))) - ((or 'regular 'symlink) - ;; Comparing file names is always tricky business so we rely on - ;; inode numbers instead - (match (vhash-assv (stat:ino stat) inodes) - ((_ . dev) (= dev (stat:dev stat))) - (#f #f))) - (_ - #f)))))) + (catch 'git-error + (lambda () + (let* ((files (git-file-list directory)) + (inodes (fold (lambda (file result) + (let ((stat + (lstat (string-append directory "/" + file)))) + (vhash-consv (stat:ino stat) (stat:dev stat) + result))) + vlist-null + files))) + (lambda (file stat) + ;; Comparing file names is always tricky business so we rely on inode + ;; numbers instead. + (match (vhash-assv (stat:ino stat) inodes) + ((_ . dev) (= dev (stat:dev stat))) + (#f #f))))) + (const #f))) ;;; git-download.scm ends here diff --git a/guix/git.scm b/guix/git.scm index 193e2df111..0666f0c0a9 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -20,11 +20,14 @@ (define-module (guix git) #:use-module (git) #:use-module (git object) + #:use-module (guix i18n) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix records) + #:use-module (guix gexp) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -33,10 +36,16 @@ #:use-module (srfi srfi-35) #:export (%repository-cache-directory update-cached-checkout - latest-repository-commit)) + latest-repository-commit + + git-checkout + git-checkout? + git-checkout-url + git-checkout-branch)) (define %repository-cache-directory - (make-parameter "/var/cache/guix/checkouts")) + (make-parameter (string-append (cache-directory #:ensure? #f) + "/checkouts"))) (define-syntax-rule (with-libgit2 thunk ...) (begin @@ -112,7 +121,7 @@ OID (roughly the commit hash) corresponding to REF." (define* (update-cached-checkout url #:key - (ref '(branch . "origin/master")) + (ref '(branch . "master")) (cache-directory (url-cache-directory url (%repository-cache-directory)))) @@ -122,6 +131,17 @@ to REF. REF is pair whose key is [branch | commit | tag] and value the associated data, respectively [<branch name> | <sha1> | <tag name>]." + (define canonical-ref + ;; We used to require callers to specify "origin/" for each branch, which + ;; made little sense since the cache should be transparent to them. So + ;; here we append "origin/" if it's missing and otherwise keep it. + (match ref + (('branch . branch) + `(branch . ,(if (string-prefix? "origin/" branch) + branch + (string-append "origin/" branch)))) + (_ ref))) + (with-libgit2 (let* ((cache-exists? (openable-repository? cache-directory)) (repository (if cache-exists? @@ -130,7 +150,7 @@ data, respectively [<branch name> | <sha1> | <tag name>]." ;; Only fetch remote if it has not been cloned just before. (when cache-exists? (remote-fetch (remote-lookup repository "origin"))) - (let ((oid (switch-to-ref repository ref))) + (let ((oid (switch-to-ref repository canonical-ref))) ;; Reclaim file descriptors and memory mappings associated with ;; REPOSITORY as soon as possible. @@ -142,9 +162,10 @@ data, respectively [<branch name> | <sha1> | <tag name>]." (define* (latest-repository-commit store url #:key + (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) - (ref '(branch . "origin/master"))) + (ref '(branch . "master"))) "Return two values: the content of the git repository at URL copied into a store directory and the sha1 of the top level commit in this directory. The reference to be checkout, once the repository is fetched, is specified by REF. @@ -152,11 +173,14 @@ REF is pair whose key is [branch | commit | tag] and value the associated data, respectively [<branch name> | <sha1> | <tag name>]. Git repositories are kept in the cache directory specified by -%repository-cache-directory parameter." +%repository-cache-directory parameter. + +Log progress and checkout info to LOG-PORT." (define (dot-git? file stat) (and (string=? (basename file) ".git") (eq? 'directory (stat:type stat)))) + (format log-port "updating checkout of '~a'...~%" url) (let*-values (((checkout commit) (update-cached-checkout url @@ -165,6 +189,58 @@ Git repositories are kept in the cache directory specified by (url-cache-directory url cache-directory))) ((name) (url+commit->name url commit))) + (format log-port "retrieved commit ~a~%" commit) (values (add-to-store store name #t "sha256" checkout #:select? (negate dot-git?)) commit))) + + +;;; +;;; Checkouts. +;;; + +;; Representation of the "latest" checkout of a branch or a specific commit. +(define-record-type* <git-checkout> + git-checkout make-git-checkout + git-checkout? + (url git-checkout-url) + (branch git-checkout-branch (default "master")) + (commit git-checkout-commit (default #f))) + +(define* (latest-repository-commit* url #:key ref log-port) + ;; Monadic variant of 'latest-repository-commit'. + (lambda (store) + ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so + ;; translate it into '&message' conditions that we know will be properly + ;; handled. + (catch 'git-error + (lambda () + (values (latest-repository-commit store url + #:ref ref #:log-port log-port) + store)) + (lambda (key error . _) + (raise (condition + (&message + (message + (match ref + (('commit . commit) + (format #f (G_ "cannot fetch commit ~a from ~a: ~a") + commit url (git-error-message error))) + (('branch . branch) + (format #f (G_ "cannot fetch branch '~a' from ~a: ~a") + branch url (git-error-message error))) + (_ + (format #f (G_ "Git failure while fetching ~a: ~a") + url (git-error-message error)))))))))))) + +(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>) + system target) + ;; "Compile" CHECKOUT by updating the local checkout and adding it to the + ;; store. + (match checkout + (($ <git-checkout> url branch commit) + (latest-repository-commit* url + #:ref (if commit + `(commit . ,commit) + `(branch . ,branch)) + #:log-port (current-error-port))))) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 3634f4bb27..bfd47a831d 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -21,6 +21,7 @@ #:use-module (web uri) #:use-module (web client) #:use-module (web response) + #:use-module (sxml simple) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -218,7 +219,7 @@ network to check in GNU's database." ;;; -;;; Latest release. +;;; Latest FTP release. ;;; (define (ftp-server/directory package) @@ -247,7 +248,7 @@ network to check in GNU's database." (define (release-file? project file) "Return #f if FILE is not a release tarball of PROJECT, otherwise return true." - (and (not (string-suffix? ".sig" file)) + (and (not (member (file-extension file) '("sig" "sign" "asc"))) (and=> (regexp-exec %tarball-rx file) (lambda (match) ;; Filter out unrelated files, like `guile-www-1.1.1'. @@ -440,6 +441,88 @@ hosted on ftp.gnu.org, or not under that name (this is the case for #:server server #:directory directory)))) + +;;; +;;; Latest HTTP release. +;;; + +(define (html->sxml port) + "Read HTML from PORT and return the corresponding SXML tree." + (let ((str (get-string-all port))) + (catch #t + (lambda () + ;; XXX: This is the poor developer's HTML-to-XML converter. It's good + ;; enough for directory listings at <https://kernel.org/pub> but if + ;; needed we could resort to (htmlprag) from Guile-Lib. + (call-with-input-string (string-replace-substring str "<hr>" "<hr />") + xml->sxml)) + (const '(html))))) ;parse error + +(define (html-links sxml) + "Return the list of links found in SXML, the SXML tree of an HTML page." + (let loop ((sxml sxml) + (links '())) + (match sxml + (('a ('@ attributes ...) body ...) + (match (assq 'href attributes) + (#f (fold loop links body)) + (('href url) (fold loop (cons url links) body)))) + ((tag ('@ _ ...) body ...) + (fold loop links body)) + ((tag body ...) + (fold loop links body)) + (_ + links)))) + +(define* (latest-html-release package + #:key + (base-url "https://kernel.org/pub") + (directory (string-append "/" package)) + (file->signature (cut string-append <> ".sig"))) + "Return an <upstream-source> for the latest release of PACKAGE (a string) on +SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page, +typically a directory listing as found on 'https://kernel.org/pub'. + +FILE->SIGNATURE must be a procedure; it is passed a source file URL and must +return the corresponding signature URL, or #f it signatures are unavailable." + (let* ((uri (string->uri (string-append base-url directory "/"))) + (port (http-fetch/cached uri #:ttl 3600)) + (sxml (html->sxml port))) + (define (url->release url) + (and (string=? url (basename url)) ;relative reference? + (release-file? package url) + (let-values (((name version) + (package-name->name+version (sans-extension url) + #\-))) + (upstream-source + (package name) + (version version) + (urls (list (string-append base-url directory "/" url))) + (signature-urls + (list (string-append base-url directory "/" + (file-sans-extension url) + ".sign"))))))) + + (define candidates + (filter-map url->release (html-links sxml))) + + (close-port port) + (match candidates + (() #f) + ((first . _) + ;; Select the most recent release and return it. + (reduce (lambda (r1 r2) + (if (version>? (upstream-source-version r1) + (upstream-source-version r2)) + r1 r2)) + first + (coalesce-sources candidates)))))) + + +;;; +;;; Updaters. +;;; + (define %gnu-file-list-uri ;; URI of the file list for ftp.gnu.org. (string->uri "https://ftp.gnu.org/find.txt.gz")) @@ -555,19 +638,21 @@ releases are on gnu.org." (define (latest-kernel.org-release package) "Return the latest release of PACKAGE, the name of a kernel.org package." - (let ((uri (string->uri (origin-uri (package-source package))))) - (false-if-ftp-error - (latest-ftp-release - (package-name package) - #:server "ftp.free.fr" ;a mirror reachable over FTP - #:directory (string-append "/mirrors/ftp.kernel.org" - (dirname (uri-path uri))) - - ;; kernel.org provides "foo-x.y.tar.sign" files, which are signatures of - ;; the uncompressed tarball. - #:file->signature (lambda (tarball) - (string-append (file-sans-extension tarball) - ".sign")))))) + (define %kernel.org-base + ;; This URL and sub-directories thereof are nginx-generated directory + ;; listings suitable for 'latest-html-release'. + "https://mirrors.edge.kernel.org/pub") + + (define (file->signature file) + (string-append (file-sans-extension file) ".sign")) + + (let* ((uri (string->uri (origin-uri (package-source package)))) + (package (package-upstream-name package)) + (directory (dirname (uri-path uri)))) + (latest-html-release package + #:base-url %kernel.org-base + #:directory directory + #:file->signature file->signature))) (define %gnu-updater ;; This is for everything at ftp.gnu.org. diff --git a/guix/gnupg.scm b/guix/gnupg.scm index ac0ed5ab2d..40feb44561 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -24,9 +24,12 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 i18n) #:use-module (srfi srfi-1) - #:use-module (guix ui) + #:use-module (guix i18n) + #:use-module ((guix utils) #:select (config-directory)) + #:use-module ((guix build utils) #:select (mkdir-p)) #:export (%gpg-command %openpgp-key-server + current-keyring gnupg-verify gnupg-verify* gnupg-status-good-signature? @@ -42,13 +45,25 @@ ;; The GnuPG 2.x command-line program name. (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg"))) +(define %gpgv-command + ;; The 'gpgv' program. + (make-parameter (or (getenv "GUIX_GPGV_COMMAND") "gpgv"))) + +(define current-keyring + ;; The default keyring of "trusted keys". + (make-parameter (string-append (config-directory #:ensure? #f) + "/gpg/trustedkeys.kbx"))) + (define %openpgp-key-server ;; The default key server. Note that keys.gnupg.net appears to be ;; unreliable. - (make-parameter "pgp.mit.edu")) + (make-parameter "pool.sks-keyservers.net")) -(define (gnupg-verify sig file) - "Verify signature SIG for FILE. Return a status s-exp if GnuPG failed." +(define* (gnupg-verify sig file + #:optional (keyring (current-keyring))) + "Verify signature SIG for FILE against the keys in KEYRING. All the keys in +KEYRING as assumed to be \"trusted\", whether or not they expired or were +revoked. Return a status s-exp if GnuPG failed." (define (status-line->sexp line) ;; See file `doc/DETAILS' in GnuPG. @@ -117,8 +132,8 @@ (loop (read-line input) (cons (status-line->sexp line) result))))) - (let* ((pipe (open-pipe* OPEN_READ (%gpg-command) "--status-fd=1" - "--verify" sig file)) + (let* ((pipe (open-pipe* OPEN_READ (%gpgv-command) "--status-fd=1" + "--keyring" keyring sig file)) (status (parse-status pipe))) ;; Ignore PIPE's exit status since STATUS above should contain all the ;; info we need. @@ -145,12 +160,21 @@ missing key." (_ #f))) status)) -(define (gnupg-receive-keys key-id server) - (system* (%gpg-command) "--keyserver" server "--recv-keys" key-id)) +(define* (gnupg-receive-keys key-id server + #:optional (keyring (current-keyring))) + (unless (file-exists? keyring) + (mkdir-p (dirname keyring)) + (call-with-output-file keyring (const #t))) ;create an empty keybox + + (system* (%gpg-command) "--keyserver" server + "--no-default-keyring" "--keyring" keyring + "--recv-keys" key-id)) (define* (gnupg-verify* sig file - #:key (key-download 'interactive) - (server (%openpgp-key-server))) + #:key + (key-download 'interactive) + (server (%openpgp-key-server)) + (keyring (current-keyring))) "Like `gnupg-verify', but try downloading the public key if it's missing. Return #t if the signature was good, #f otherwise. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'always', 'never', @@ -161,15 +185,17 @@ and 'interactive' (default)." (define (download-and-try-again) ;; Download the missing key and try again. (begin - (gnupg-receive-keys missing server) - (gnupg-status-good-signature? (gnupg-verify sig file)))) + (gnupg-receive-keys missing server keyring) + (gnupg-status-good-signature? (gnupg-verify sig file + keyring)))) (define (receive?) (let ((answer - (begin (format #t (G_ "~a~a~%") - "Would you like to download this key " - "and add it to your keyring?") - (read-line)))) + (begin + (format #t (G_ "Would you like to add this key \ +to keyring '~a'?~%") + keyring) + (read-line)))) (string-match (locale-yes-regexp) answer))) (and missing diff --git a/guix/grafts.scm b/guix/grafts.scm index f303e925f1..63f384555b 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -40,7 +40,8 @@ graft-derivation/shallow %graft? - set-grafting)) + set-grafting + grafting?)) (define-record-type* <graft> graft make-graft graft? @@ -122,6 +123,10 @@ are not recursively applied to dependencies of DRV." (define add-label (cut cons "x" <>)) + (define properties + `((type . graft) + (graft (count . ,(length grafts))))) + (match grafts ((($ <graft> sources source-outputs targets target-outputs) ...) (let ((sources (zip sources source-outputs)) @@ -139,7 +144,8 @@ are not recursively applied to dependencies of DRV." ,@(append (map add-label sources) (map add-label targets))) #:outputs outputs - #:local-build? #t))))) + #:local-build? #t + #:properties properties))))) (define (item->deriver store item) "Return two values: the derivation that led to ITEM (a store item), and the name of the output of that derivation ITEM corresponds to (for example @@ -328,6 +334,11 @@ it otherwise. It returns the previous setting." (lambda (store) (values (%graft? enable?) store))) +(define (grafting?) + "Return a Boolean indicating whether grafting is enabled." + (lambda (store) + (values (%graft?) store))) + ;; Local Variables: ;; eval: (put 'with-cache 'scheme-indent-function 1) ;; End: diff --git a/guix/hash.scm b/guix/hash.scm deleted file mode 100644 index 8d7ba21425..0000000000 --- a/guix/hash.scm +++ /dev/null @@ -1,184 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 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 hash) - #:use-module (guix gcrypt) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 binary-ports) - #:use-module (system foreign) - #:use-module ((guix build utils) #:select (dump-port)) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:export (sha1 - sha256 - open-sha256-port - port-sha256 - file-sha256 - open-sha256-input-port)) - -;;; Commentary: -;;; -;;; Cryptographic hashes. -;;; -;;; Code: - - -;;; -;;; Hash. -;;; - -(define-syntax GCRY_MD_SHA256 - ;; Value as of Libgcrypt 1.5.2. - (identifier-syntax 8)) - -(define-syntax GCRY_MD_SHA1 - (identifier-syntax 2)) - -(define bytevector-hash - (let ((hash (pointer->procedure void - (libgcrypt-func "gcry_md_hash_buffer") - `(,int * * ,size_t)))) - (lambda (bv type size) - "Return the hash TYPE, of SIZE bytes, of BV as a bytevector." - (let ((digest (make-bytevector size))) - (hash type (bytevector->pointer digest) - (bytevector->pointer bv) (bytevector-length bv)) - digest)))) - -(define sha1 - (cut bytevector-hash <> GCRY_MD_SHA1 20)) - -(define sha256 - (cut bytevector-hash <> GCRY_MD_SHA256 (/ 256 8))) - -(define open-sha256-md - (let ((open (pointer->procedure int - (libgcrypt-func "gcry_md_open") - `(* ,int ,unsigned-int)))) - (lambda () - (let* ((md (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (open md GCRY_MD_SHA256 0))) - (if (zero? err) - (dereference-pointer md) - (throw 'gcrypt-error err)))))) - -(define md-write - (pointer->procedure void - (libgcrypt-func "gcry_md_write") - `(* * ,size_t))) - -(define md-read - (pointer->procedure '* - (libgcrypt-func "gcry_md_read") - `(* ,int))) - -(define md-close - (pointer->procedure void - (libgcrypt-func "gcry_md_close") - '(*))) - - -(define (open-sha256-port) - "Return two values: an output port, and a thunk. When the thunk is called, -it returns the SHA256 hash (a bytevector) of all the data written to the -output port." - (define sha256-md - (open-sha256-md)) - - (define digest #f) - (define position 0) - - (define (finalize!) - (let ((ptr (md-read sha256-md 0))) - (set! digest (bytevector-copy (pointer->bytevector ptr 32))) - (md-close sha256-md))) - - (define (write! bv offset len) - (if (zero? len) - (begin - (finalize!) - 0) - (let ((ptr (bytevector->pointer bv offset))) - (md-write sha256-md ptr len) - (set! position (+ position len)) - len))) - - (define (get-position) - position) - - (define (close) - (unless digest - (finalize!))) - - (values (make-custom-binary-output-port "sha256" - write! get-position #f - close) - (lambda () - (unless digest - (finalize!)) - digest))) - -(define (port-sha256 port) - "Return the SHA256 hash (a bytevector) of all the data drained from PORT." - (let-values (((out get) - (open-sha256-port))) - (dump-port port out) - (close-port out) - (get))) - -(define (file-sha256 file) - "Return the SHA256 hash (a bytevector) of FILE." - (call-with-input-file file port-sha256)) - -(define (open-sha256-input-port port) - "Return an input port that wraps PORT and a thunk to get the hash of all the -data read from PORT. The thunk always returns the same value." - (define md - (open-sha256-md)) - - (define (read! bv start count) - (let ((n (get-bytevector-n! port bv start count))) - (if (eof-object? n) - 0 - (begin - (unless digest - (let ((ptr (bytevector->pointer bv start))) - (md-write md ptr n))) - n)))) - - (define digest #f) - - (define (finalize!) - (let ((ptr (md-read md 0))) - (set! digest (bytevector-copy (pointer->bytevector ptr 32))) - (md-close md))) - - (define (get-hash) - (unless digest - (finalize!)) - digest) - - (define (unbuffered port) - ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports. - (setvbuf port _IONBF) - port) - - (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f)) - get-hash)) - -;;; hash.scm ends here diff --git a/guix/http-client.scm b/guix/http-client.scm index 3b34d4ffba..07360e6108 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -34,7 +34,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix base64) - #:autoload (guix hash) (sha256) + #:autoload (gcrypt hash) (sha256) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index d0ff64ed05..d4bea84353 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -27,7 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (json) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix base32) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index a5203fe78d..8f2c10258a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -29,7 +29,7 @@ #:use-module (web uri) #:use-module (guix memoization) #:use-module (guix http-client) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) @@ -127,9 +127,9 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.7. Bioconductor packages should be +;; The latest Bioconductor release is 3.8. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.7") +(define %bioconductor-version "3.8") (define %bioconductor-packages-list-url (string-append "https://bioconductor.org/packages/" diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 3724a457a4..e0b400d054 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -20,7 +20,7 @@ #:use-module (guix base32) #:use-module (guix build-system cargo) #:use-module ((guix download) #:prefix download:) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix http-client) #:use-module (guix import json) #:use-module (guix import utils) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index c37afaf8e6..83354d3f04 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -32,7 +32,7 @@ #:use-module (guix http-client) #:use-module (guix store) #:use-module (guix ui) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix upstream) #:use-module (guix packages) diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index bbb17047f0..29324d7554 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -21,7 +21,7 @@ #:use-module (guix import utils) #:use-module (guix utils) #:use-module (guix store) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix upstream) #:use-module (srfi srfi-1) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 3c00f680bf..48db764b3c 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -33,7 +33,7 @@ #:use-module ((guix import utils) #:select (factorize-uri recursive-import)) #:use-module (guix import cabal) #:use-module (guix store) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix memoization) #:use-module (guix upstream) @@ -44,6 +44,7 @@ %hackage-updater guix-package->hackage-name + hackage-name->package-name hackage-fetch hackage-source-url hackage-cabal-url @@ -214,15 +215,18 @@ representation of a Cabal file as produced by 'read-cabal'." cabal)) (define hackage-native-dependencies - ((compose (cut filter-dependencies <> - (cabal-package-name cabal)) - ;; FIXME: Check include-test-dependencies? - (lambda (cabal) - (append (if include-test-dependencies? - (cabal-test-dependencies->names cabal) - '()) - (cabal-custom-setup-dependencies->names cabal)))) - cabal)) + (lset-difference + equal? + ((compose (cut filter-dependencies <> + (cabal-package-name cabal)) + ;; FIXME: Check include-test-dependencies? + (lambda (cabal) + (append (if include-test-dependencies? + (cabal-test-dependencies->names cabal) + '()) + (cabal-custom-setup-dependencies->names cabal)))) + cabal) + hackage-dependencies)) (define dependencies (map (lambda (name) diff --git a/guix/import/json.scm b/guix/import/json.scm index 4f96a513df..81ea5e7b31 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -47,4 +47,5 @@ the query." (define (json-fetch-alist url) "Return an alist representation of the JSON resource URL, or #f if URL returns 403 or 404." - (hash-table->alist (json-fetch url))) + (and=> (json-fetch url) + hash-table->alist)) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 25560bac46..3a20fc4b9b 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:use-module (ice-9 regex) + #:use-module (ice-9 receive) #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -36,7 +38,8 @@ #:use-module (guix utils) #:use-module ((guix build utils) #:select ((package-name->name+version - . hyphen-package-name->name+version))) + . hyphen-package-name->name+version) + find-files)) #:use-module (guix import utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) @@ -45,6 +48,7 @@ #:use-module ((guix licenses) #:prefix license:) #:use-module (guix build-system python) #:export (guix-package->pypi-name + pypi-recursive-import pypi->guix-package %pypi-updater)) @@ -114,9 +118,9 @@ package definition." `((propagated-inputs (,'quasiquote ,package-inputs)))))) (define (guess-requirements source-url wheel-url tarball) - "Given SOURCE-URL, WHEEL-URL and a TARBALL of the package, return a list of -the required packages specified in the requirements.txt file. TARBALL will be -extracted in the current directory, and will be deleted." + "Given SOURCE-URL, WHEEL-URL and a TARBALL of the package, return a list +of the required packages specified in the requirements.txt file. TARBALL will +be extracted in a temporary directory." (define (tarball-directory url) ;; Given the URL of the package's tarball, return the name of the directory @@ -140,8 +144,8 @@ cannot determine package dependencies")) ;; file, remove everything other than the actual name of the required ;; package, and return it. (string-take s - (or (string-index s #\space) - (string-length s)))) + (or (string-index s (lambda (chr) (member chr '(#\space #\> #\= #\<)))) + (string-length s)))) (define (comment? line) ;; Return #t if the given LINE is a comment, #f otherwise. @@ -160,7 +164,7 @@ cannot determine package dependencies")) ((or (string-null? line) (comment? line)) (loop result)) (else - (loop (cons (python->package-name (clean-requirement line)) + (loop (cons (clean-requirement line) result)))))))))) (define (read-wheel-metadata wheel-archive) @@ -180,9 +184,7 @@ cannot determine package dependencies")) (hash-ref (list-ref run_requires 0) "requires") '()))) - (map (lambda (r) - (python->package-name (clean-requirement r))) - requirements))))) + (map clean-requirement requirements))))) (lambda () (delete-file json-file) (rmdir dirname)))))) @@ -197,31 +199,37 @@ cannot determine package dependencies")) (read-wheel-metadata temp)) #f)))) - (define (guess-requirements-from-source) ;; Return the package's requirements by guessing them from the source. (let ((dirname (tarball-directory source-url))) (if (string? dirname) - (let* ((req-file (string-append dirname "/requirements.txt")) - (exit-code (system* "tar" "xf" tarball req-file))) - ;; TODO: support more formats. - (if (zero? exit-code) - (dynamic-wind - (const #t) - (lambda () - (read-requirements req-file)) - (lambda () - (delete-file req-file) - (rmdir dirname))) - (begin - (warning (G_ "'tar xf' failed with exit code ~a\n") - exit-code) - '()))) + (call-with-temporary-directory + (lambda (dir) + (let* ((pypi-name (string-take dirname (string-rindex dirname #\-))) + (req-files (list (string-append dirname "/requirements.txt") + (string-append dirname "/" pypi-name ".egg-info" + "/requires.txt"))) + (exit-codes (map (lambda (file-name) + (parameterize ((current-error-port (%make-void-port "rw+")) + (current-output-port (%make-void-port "rw+"))) + (system* "tar" "xf" tarball "-C" dir file-name))) + req-files))) + ;; Only one of these files needs to exist. + (if (any zero? exit-codes) + (match (find-files dir) + ((file . _) + (read-requirements file)) + (() + (warning (G_ "No requirements file found.\n")))) + (begin + (warning (G_ "Failed to extract requirements files\n")) + '()))))) '()))) ;; First, try to compute the requirements using the wheel, since that is the ;; most reliable option. If a wheel is not provided for this package, try - ;; getting them by reading the "requirements.txt" file from the source. Note + ;; getting them by reading either the "requirements.txt" file or the + ;; "requires.txt" from the egg-info directory from the source tarball. Note ;; that "requirements.txt" is not mandatory, so this is likely to fail. (or (guess-requirements-from-wheel) (guess-requirements-from-source))) @@ -229,16 +237,21 @@ cannot determine package dependencies")) (define (compute-inputs source-url wheel-url tarball) "Given the SOURCE-URL of an already downloaded TARBALL, return a list of -name/variable pairs describing the required inputs of this package." - (sort - (map (lambda (input) - (list input (list 'unquote (string->symbol input)))) - (remove (cut string=? "python-argparse" <>) - (guess-requirements source-url wheel-url tarball))) - (lambda args - (match args - (((a _ ...) (b _ ...)) - (string-ci<? a b)))))) +name/variable pairs describing the required inputs of this package. Also +return the unaltered list of upstream dependency names." + (let ((dependencies + (remove (cut string=? "argparse" <>) + (guess-requirements source-url wheel-url tarball)))) + (values (sort + (map (lambda (input) + (let ((guix-name (python->package-name input))) + (list guix-name (list 'unquote (string->symbol guix-name))))) + dependencies) + (lambda args + (match args + (((a _ ...) (b _ ...)) + (string-ci<? a b))))) + dependencies))) (define (make-pypi-sexp name version source-url wheel-url home-page synopsis description license) @@ -247,46 +260,58 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) - `(package - (name ,(python->package-name name)) - (version ,version) - (source (origin - (method url-fetch) + (receive (input-package-names upstream-dependency-names) + (compute-inputs source-url wheel-url temp) + (values + `(package + (name ,(python->package-name name)) + (version ,version) + (source (origin + (method url-fetch) - ;; Sometimes 'pypi-uri' doesn't quite work due to mixed - ;; cases in NAME, for instance, as is the case with - ;; "uwsgi". In that case, fall back to a full URL. - (uri (pypi-uri ,(string-downcase name) version)) - (sha256 - (base32 - ,(guix-hash-url temp))))) - (build-system python-build-system) - ,@(maybe-inputs (compute-inputs source-url wheel-url temp)) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,description) - (license ,(license->symbol license))))))) + ;; Sometimes 'pypi-uri' doesn't quite work due to mixed + ;; cases in NAME, for instance, as is the case with + ;; "uwsgi". In that case, fall back to a full URL. + (uri (pypi-uri ,(string-downcase name) version)) + (sha256 + (base32 + ,(guix-hash-url temp))))) + (build-system python-build-system) + ,@(maybe-inputs input-package-names) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(license->symbol license))) + upstream-dependency-names)))))) -(define (pypi->guix-package package-name) - "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the +(define pypi->guix-package + (memoize + (lambda* (package-name) + "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." - (let ((package (pypi-fetch package-name))) - (and package - (guard (c ((missing-source-error? c) - (let ((package (missing-source-error-package c))) - (leave (G_ "no source release for pypi package ~a ~a~%") - (assoc-ref* package "info" "name") - (assoc-ref* package "info" "version"))))) - (let ((name (assoc-ref* package "info" "name")) - (version (assoc-ref* package "info" "version")) - (release (assoc-ref (latest-source-release package) "url")) - (wheel (assoc-ref (latest-wheel-release package) "url")) - (synopsis (assoc-ref* package "info" "summary")) - (description (assoc-ref* package "info" "summary")) - (home-page (assoc-ref* package "info" "home_page")) - (license (string->license (assoc-ref* package "info" "license")))) - (make-pypi-sexp name version release wheel home-page synopsis - description license)))))) + (let ((package (pypi-fetch package-name))) + (and package + (guard (c ((missing-source-error? c) + (let ((package (missing-source-error-package c))) + (leave (G_ "no source release for pypi package ~a ~a~%") + (assoc-ref* package "info" "name") + (assoc-ref* package "info" "version"))))) + (let ((name (assoc-ref* package "info" "name")) + (version (assoc-ref* package "info" "version")) + (release (assoc-ref (latest-source-release package) "url")) + (wheel (assoc-ref (latest-wheel-release package) "url")) + (synopsis (assoc-ref* package "info" "summary")) + (description (assoc-ref* package "info" "summary")) + (home-page (assoc-ref* package "info" "home_page")) + (license (string->license (assoc-ref* package "info" "license")))) + (make-pypi-sexp name version release wheel home-page synopsis + description license)))))))) + +(define (pypi-recursive-import package-name) + (recursive-import package-name #f + #:repo->guix-package (lambda (name repo) + (pypi->guix-package name)) + #:guix-name python->package-name)) (define (string->license str) "Convert the string STR into a license object." @@ -305,7 +330,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define (pypi-url? url) (or (string-prefix? "https://pypi.org/" url) (string-prefix? "https://pypi.python.org/" url) - (string-prefix? "https://pypi.io/packages" url))) + (string-prefix? "https://pypi.org/packages" url))) (let ((source-url (and=> (package-source package) origin-uri)) (fetch-method (and=> (package-source package) origin-method))) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index ec93fbced6..1c1e73a723 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,10 +26,12 @@ #:use-module (srfi srfi-35) #:use-module (guix import json) #:use-module (guix import hackage) + #:use-module (guix import utils) #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix upstream) #:export (stackage->guix-package + stackage-recursive-import %stackage-updater)) @@ -40,15 +43,12 @@ (define (lts-info-ghc-version lts-info) "Retruns the version of the GHC compiler contained in LTS-INFO." - (match lts-info - ((("snapshot" ("ghc" . version) _ _) _) version) - (_ #f))) + (and=> (assoc-ref lts-info "snapshot") + (cut assoc-ref <> "ghc"))) (define (lts-info-packages lts-info) "Retruns the alist of packages contained in LTS-INFO." - (match lts-info - ((_ ("packages" pkg ...)) pkg) - (_ '()))) + (or (assoc-ref lts-info "packages") '())) (define (leave-with-message fmt . args) (raise (condition (&message (message (apply format #f fmt args)))))) @@ -85,25 +85,33 @@ (define (hackage-name-version name version) (and version (string-append name "@" version))) -(define* (stackage->guix-package package-name ; upstream name - #:key - (include-test-dependencies? #t) - (lts-version "") - (packages-info - (lts-info-packages - (stackage-lts-info-fetch lts-version)))) - "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved +(define stackage->guix-package + (memoize + (lambda* (package-name ; upstream name + #:key + (include-test-dependencies? #t) + (lts-version "") + (packages-info + (lts-info-packages + (stackage-lts-info-fetch lts-version)))) + "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved vesion corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to that package, or #f on failure. PACKAGES-INFO is the alist with the packages included in the Stackage LTS release." - (let* ((version (lts-package-version packages-info package-name)) - (name-version (hackage-name-version package-name version))) - (if name-version - (hackage->guix-package name-version - #:include-test-dependencies? - include-test-dependencies?) - (leave-with-message "~a: Stackage package not found" package-name)))) + (let* ((version (lts-package-version packages-info package-name)) + (name-version (hackage-name-version package-name version))) + (if name-version + (hackage->guix-package name-version + #:include-test-dependencies? + include-test-dependencies?) + (leave-with-message "~a: Stackage package not found" package-name)))))) + +(define (stackage-recursive-import package-name . args) + (recursive-import package-name #f + #:repo->guix-package (lambda (name repo) + (apply stackage->guix-package (cons name args))) + #:guix-name hackage-name->package-name)) ;;; diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index d4c3714364..791b514485 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -26,7 +26,7 @@ #:use-module (srfi srfi-34) #:use-module (web uri) #:use-module (guix http-client) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix memoization) #:use-module (guix store) #:use-module (guix base32) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 0dc8fd5857..516c0cfaa2 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -23,7 +23,7 @@ (define-module (guix import utils) #:use-module (guix base32) #:use-module ((guix build download) #:prefix build:) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) diff --git a/guix/inferior.scm b/guix/inferior.scm index 05c8d65deb..ccc1c27cb2 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -19,21 +19,69 @@ (define-module (guix inferior) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module ((guix utils) + #:select (%current-system + source-properties->location + call-with-temporary-directory + version>? version-prefix? + cache-directory)) + #:use-module ((guix store) + #:select (nix-server-socket + nix-server-major-version + nix-server-minor-version + store-lift)) + #:use-module ((guix derivations) + #:select (read-derivation-from-file)) + #:use-module (guix gexp) + #:use-module (guix search-paths) + #:use-module (guix profiles) + #:use-module (guix channels) + #:use-module (guix monads) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix base32) + #:use-module (gcrypt hash) + #:autoload (guix cache) (maybe-remove-expired-cache-entries) + #:autoload (guix ui) (show-what-to-build*) + #:autoload (guix build utils) (mkdir-p) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:autoload (ice-9 ftw) (scandir) #:use-module (ice-9 match) #:use-module (ice-9 popen) + #:use-module (ice-9 vlist) + #:use-module (ice-9 binary-ports) + #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior close-inferior inferior-eval + inferior-eval-with-store inferior-object? + inferior-packages + lookup-inferior-packages + inferior-package? inferior-package-name inferior-package-version - - inferior-packages inferior-package-synopsis - inferior-package-description)) + inferior-package-description + inferior-package-home-page + inferior-package-location + inferior-package-inputs + inferior-package-native-inputs + inferior-package-propagated-inputs + inferior-package-transitive-propagated-inputs + inferior-package-native-search-paths + inferior-package-transitive-native-search-paths + inferior-package-search-paths + inferior-package-derivation + + inferior-package->manifest-entry + + %inferior-cache-directory + inferior-for-channels)) ;;; Commentary: ;;; @@ -45,11 +93,13 @@ ;; Inferior Guix process. (define-record-type <inferior> - (inferior pid socket version) + (inferior pid socket version packages table) inferior? (pid inferior-pid) (socket inferior-socket) - (version inferior-version)) ;REPL protocol version + (version inferior-version) ;REPL protocol version + (packages inferior-package-promise) ;promise of inferior packages + (table inferior-package-table)) ;promise of vhash (define (inferior-pipe directory command) "Return an input/output pipe on the Guix instance in DIRECTORY. This runs @@ -93,9 +143,12 @@ equivalent. Return #f if the inferior could not be launched." (match (read pipe) (('repl-version 0 rest ...) - (let ((result (inferior 'pipe pipe (cons 0 rest)))) + (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (delay (%inferior-packages result)) + (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) + (inferior-eval '(use-modules (ice-9 match)) result) (inferior-eval '(define %package-table (make-hash-table)) result) result)) @@ -120,8 +173,7 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! <inferior-object> write-inferior-object) -(define (inferior-eval exp inferior) - "Evaluate EXP in INFERIOR." +(define (read-inferior-response inferior) (define sexp->object (match-lambda (('value value) @@ -129,14 +181,21 @@ equivalent. Return #f if the inferior could not be launched." (('non-self-quoting address string) (inferior-object address string)))) - (write exp (inferior-socket inferior)) - (newline (inferior-socket inferior)) (match (read (inferior-socket inferior)) (('values objects ...) (apply values (map sexp->object objects))) (('exception key objects ...) (apply throw key (map sexp->object objects))))) +(define (send-inferior-request exp inferior) + (write exp (inferior-socket inferior)) + (newline (inferior-socket inferior))) + +(define (inferior-eval exp inferior) + "Evaluate EXP in INFERIOR." + (send-inferior-request exp inferior) + (read-inferior-response inferior)) + ;;; ;;; Inferior packages. @@ -159,8 +218,8 @@ equivalent. Return #f if the inferior could not be launched." (set-record-type-printer! <inferior-package> write-inferior-package) -(define (inferior-packages inferior) - "Return the list of packages known to INFERIOR." +(define (%inferior-packages inferior) + "Compute the list of inferior packages from INFERIOR." (let ((result (inferior-eval '(fold-packages (lambda (package result) (let ((id (object-address package))) @@ -176,6 +235,33 @@ equivalent. Return #f if the inferior could not be launched." (inferior-package inferior name version id))) result))) +(define (inferior-packages inferior) + "Return the list of packages known to INFERIOR." + (force (inferior-package-promise inferior))) + +(define (%inferior-package-table inferior) + "Compute a package lookup table for INFERIOR." + (fold (lambda (package table) + (vhash-cons (inferior-package-name package) package + table)) + vlist-null + (inferior-packages inferior))) + +(define* (lookup-inferior-packages inferior name #:optional version) + "Return the sorted list of inferior packages matching NAME in INFERIOR, with +highest version numbers first. If VERSION is true, return only packages with +a version number prefixed by VERSION." + ;; This is the counterpart of 'find-packages-by-name'. + (sort (filter (lambda (package) + (or (not version) + (version-prefix? version + (inferior-package-version package)))) + (vhash-fold* cons '() name + (force (inferior-package-table inferior)))) + (lambda (p1 p2) + (version>? (inferior-package-version p1) + (inferior-package-version p2))))) + (define (inferior-package-field package getter) "Return the field of PACKAGE, an inferior package, accessed with GETTER." (let ((inferior (inferior-package-inferior package)) @@ -198,3 +284,291 @@ TRANSLATE? is true, translate it to the current locale's language." (if translate? '(compose (@ (guix ui) P_) package-description) 'package-description))) + +(define (inferior-package-home-page package) + "Return the home page of PACKAGE." + (inferior-package-field package 'package-home-page)) + +(define (inferior-package-location package) + "Return the source code location of PACKAGE, either #f or a <location> +record." + (source-properties->location + (inferior-package-field package + '(compose (lambda (loc) + (and loc + (location->source-properties + loc))) + package-location)))) + +(define (inferior-package-input-field package field) + "Return the input field FIELD (e.g., 'native-inputs') of PACKAGE, an +inferior package." + (define field* + `(compose (lambda (inputs) + (map (match-lambda + ;; XXX: Origins are not handled. + ((label (? package? package) rest ...) + (let ((id (object-address package))) + (hashv-set! %package-table id package) + `(,label (package ,id + ,(package-name package) + ,(package-version package)) + ,@rest))) + (x + x)) + inputs)) + ,field)) + + (define inputs + (inferior-package-field package field*)) + + (define inferior + (inferior-package-inferior package)) + + (map (match-lambda + ((label ('package id name version) . rest) + ;; XXX: eq?-ness of inferior packages is not preserved here. + `(,label ,(inferior-package inferior name version id) + ,@rest)) + (x x)) + inputs)) + +(define inferior-package-inputs + (cut inferior-package-input-field <> 'package-inputs)) + +(define inferior-package-native-inputs + (cut inferior-package-input-field <> 'package-native-inputs)) + +(define inferior-package-propagated-inputs + (cut inferior-package-input-field <> 'package-propagated-inputs)) + +(define inferior-package-transitive-propagated-inputs + (cut inferior-package-input-field <> 'package-transitive-propagated-inputs)) + +(define (%inferior-package-search-paths package field) + "Return the list of search path specificiations of PACKAGE, an inferior +package." + (define paths + (inferior-package-field package + `(compose (lambda (paths) + (map (@ (guix search-paths) + search-path-specification->sexp) + paths)) + ,field))) + + (map sexp->search-path-specification paths)) + +(define inferior-package-native-search-paths + (cut %inferior-package-search-paths <> 'package-native-search-paths)) + +(define inferior-package-search-paths + (cut %inferior-package-search-paths <> 'package-search-paths)) + +(define inferior-package-transitive-native-search-paths + (cut %inferior-package-search-paths <> 'package-transitive-native-search-paths)) + +(define (proxy client backend) ;adapted from (guix ssh) + "Proxy communication between CLIENT and BACKEND until CLIENT closes the +connection, at which point CLIENT is closed (both CLIENT and BACKEND must be +input/output ports.)" + (define (select* read write except) + ;; This is a workaround for <https://bugs.gnu.org/30365> in Guile < 2.2.4: + ;; since 'select' sometimes returns non-empty sets for no good reason, + ;; call 'select' a second time with a zero timeout to filter out incorrect + ;; replies. + (match (select read write except) + ((read write except) + (select read write except 0)))) + + ;; Use buffered ports so that 'get-bytevector-some' returns up to the + ;; whole buffer like read(2) would--see <https://bugs.gnu.org/30066>. + (setvbuf client _IOFBF 65536) + (setvbuf backend _IOFBF 65536) + + (let loop () + (match (select* (list client backend) '() '()) + ((reads () ()) + (when (memq client reads) + (match (get-bytevector-some client) + ((? eof-object?) + (close-port client)) + (bv + (put-bytevector backend bv) + (force-output backend)))) + (when (memq backend reads) + (match (get-bytevector-some backend) + (bv + (put-bytevector client bv) + (force-output client)))) + (unless (port-closed? client) + (loop)))))) + +(define (inferior-eval-with-store inferior store code) + "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must +thus be the code of a one-argument procedure that accepts a store." + ;; Create a named socket in /tmp and let INFERIOR connect to it and use it + ;; as its store. This ensures the inferior uses the same store, with the + ;; same options, the same per-session GC roots, etc. + (call-with-temporary-directory + (lambda (directory) + (chmod directory #o700) + (let* ((name (string-append directory "/inferior")) + (socket (socket AF_UNIX SOCK_STREAM 0)) + (major (nix-server-major-version store)) + (minor (nix-server-minor-version store)) + (proto (logior major minor))) + (bind socket AF_UNIX name) + (listen socket 1024) + (send-inferior-request + `(let ((proc ,code) + (socket (socket AF_UNIX SOCK_STREAM 0))) + (connect socket AF_UNIX ,name) + + ;; 'port->connection' appeared in June 2018 and we can hardly + ;; emulate it on older versions. Thus fall back to + ;; 'open-connection', at the risk of talking to the wrong daemon or + ;; having our build result reclaimed (XXX). + (let ((store (if (defined? 'port->connection) + (port->connection socket #:version ,proto) + (open-connection)))) + (dynamic-wind + (const #t) + (lambda () + (proc store)) + (lambda () + (close-connection store) + (close-port socket))))) + inferior) + (match (accept socket) + ((client . address) + (proxy client (nix-server-socket store)))) + (close-port socket) + (read-inferior-response inferior))))) + +(define* (inferior-package-derivation store package + #:optional + (system (%current-system)) + #:key target) + "Return the derivation for PACKAGE, an inferior package, built for SYSTEM +and cross-built for TARGET if TARGET is true. The inferior corresponding to +PACKAGE must be live." + (define proc + `(lambda (store) + (let* ((package (hashv-ref %package-table + ,(inferior-package-id package))) + (drv ,(if target + `(package-cross-derivation store package + ,target + ,system) + `(package-derivation store package + ,system)))) + (derivation-file-name drv)))) + + (and=> (inferior-eval-with-store (inferior-package-inferior package) store + proc) + read-derivation-from-file)) + +(define inferior-package->derivation + (store-lift inferior-package-derivation)) + +(define-gexp-compiler (package-compiler (package <inferior-package>) system + target) + ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. + (inferior-package->derivation package system #:target target)) + + +;;; +;;; Manifest entries. +;;; + +(define* (inferior-package->manifest-entry package + #:optional (output "out") + #:key (parent (delay #f)) + (properties '())) + "Return a manifest entry for the OUTPUT of package PACKAGE." + ;; For each dependency, keep a promise pointing to its "parent" entry. + (letrec* ((deps (map (match-lambda + ((label package) + (inferior-package->manifest-entry package + #:parent (delay entry))) + ((label package output) + (inferior-package->manifest-entry package output + #:parent (delay entry)))) + (inferior-package-propagated-inputs package))) + (entry (manifest-entry + (name (inferior-package-name package)) + (version (inferior-package-version package)) + (output output) + (item package) + (dependencies (delete-duplicates deps)) + (search-paths + (inferior-package-transitive-native-search-paths package)) + (parent parent) + (properties properties)))) + entry)) + + +;;; +;;; Cached inferiors. +;;; + +(define %inferior-cache-directory + ;; Directory for cached inferiors (GC roots). + (make-parameter (string-append (cache-directory #:ensure? #f) + "/inferiors"))) + +(define* (inferior-for-channels channels + #:key + (cache-directory (%inferior-cache-directory)) + (ttl (* 3600 24 30))) + "Return an inferior for CHANNELS, a list of channels. Use the cache at +CACHE-DIRECTORY, where entries can be reclaimed after TTL seconds. This +procedure opens a new connection to the build daemon. + +This is a convenience procedure that people may use in manifests passed to +'guix package -m', for instance." + (with-store store + (let () + (define instances + (latest-channel-instances store channels)) + + (define key + (bytevector->base32-string + (sha256 + (string->utf8 + (string-concatenate (map channel-instance-commit instances)))))) + + (define cached + (string-append cache-directory "/" key)) + + (define (base32-encoded-sha256? str) + (= (string-length str) 52)) + + (define (cache-entries directory) + (map (lambda (file) + (string-append directory "/" file)) + (scandir directory base32-encoded-sha256?))) + + (define symlink* + (lift2 symlink %store-monad)) + + (define add-indirect-root* + (store-lift add-indirect-root)) + + (mkdir-p cache-directory) + (maybe-remove-expired-cache-entries cache-directory + cache-entries + #:entry-expiration + (file-expiration-time ttl)) + + (if (file-exists? cached) + (open-inferior cached) + (run-with-store store + (mlet %store-monad ((profile + (channel-instances->derivation instances))) + (mbegin %store-monad + (show-what-to-build* (list profile)) + (built-derivations (list profile)) + (symlink* (derivation->output-path profile) cached) + (add-indirect-root* cached) + (return (open-inferior cached))))))))) diff --git a/guix/nar.scm b/guix/nar.scm index 3556de1379..8894f10d2b 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -22,12 +22,16 @@ #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (delete-file-recursively with-directory-excursion)) + + ;; XXX: Eventually we should use (guix store database) exclusively, and not + ;; (guix store) since this is "daemon-side" code. #:use-module (guix store) #:use-module (guix store database) + #:use-module (guix ui) ; for '_' - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix pki) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -88,15 +92,12 @@ REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET before attempting to register it; otherwise, assume TARGET's locks are already held." - - ;; XXX: Currently we have to call out to the daemon to check whether TARGET - ;; is valid. - (with-store store - (unless (valid-path? store target) + (with-database %default-database-file db + (unless (path-id db target) (when lock? (lock-store-file target)) - (unless (valid-path? store target) + (unless (path-id db target) ;; If FILE already exists, delete it (it's invalid anyway.) (when (file-exists? target) (delete-file-recursively target)) diff --git a/guix/packages.scm b/guix/packages.scm index a220b9c476..eab0b3404c 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -628,12 +628,7 @@ specifies modules in scope when evaluating SNIPPET." #:fail-on-error? #t))))) (apply invoke (string-append #+tar "/bin/tar") - "cvf" #$output - ;; The bootstrap xz does not support - ;; threaded compression (introduced in - ;; 5.2.0), but it ignores the extra flag. - (string-append "--use-compress-program=" - #+xz "/bin/xz --threads=0") + "cvfa" #$output ;; avoid non-determinism in the archive "--mtime=@0" "--owner=root:0" @@ -646,9 +641,6 @@ specifies modules in scope when evaluating SNIPPET." (let ((name (tarxz-name original-file-name))) (gexp->derivation name build - ;; TODO: Remove this on the next rebuild cycle. - #:import-creates-derivation? #t - #:graft? #f #:system system #:deprecation-warnings #t ;to avoid a rebuild diff --git a/guix/pk-crypto.scm b/guix/pk-crypto.scm deleted file mode 100644 index 55ba7b1bb8..0000000000 --- a/guix/pk-crypto.scm +++ /dev/null @@ -1,407 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017 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 pk-crypto) - #:use-module (guix base16) - #:use-module (guix gcrypt) - - #:use-module (system foreign) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:export (canonical-sexp? - error-source - error-string - string->canonical-sexp - canonical-sexp->string - read-file-sexp - number->canonical-sexp - canonical-sexp-car - canonical-sexp-cdr - canonical-sexp-nth - canonical-sexp-nth-data - canonical-sexp-length - canonical-sexp-null? - canonical-sexp-list? - bytevector->hash-data - hash-data->bytevector - key-type - sign - verify - generate-key - find-sexp-token - canonical-sexp->sexp - sexp->canonical-sexp) - #:re-export (gcrypt-version)) - - -;;; Commentary: -;;; -;;; Public key cryptographic routines from GNU Libgcrypt. -;;;; -;;; Libgcrypt uses "canonical s-expressions" to represent key material, -;;; parameters, and data. We keep it as an opaque object to map them to -;;; Scheme s-expressions because (1) Libgcrypt sexps may be stored in secure -;;; memory, and (2) the read syntax is different. -;;; -;;; A 'canonical-sexp->sexp' procedure is provided nevertheless, for use in -;;; cases where it is safe to move data out of Libgcrypt---e.g., when -;;; processing ACL entries, public keys, etc. -;;; -;;; Canonical sexps were defined by Rivest et al. in the IETF draft at -;;; <http://people.csail.mit.edu/rivest/Sexp.txt> for the purposes of SPKI -;;; (see <http://www.ietf.org/rfc/rfc2693.txt>.) -;;; -;;; Code: - -;; Libgcrypt "s-expressions". -(define-wrapped-pointer-type <canonical-sexp> - canonical-sexp? - naked-pointer->canonical-sexp - canonical-sexp->pointer - (lambda (obj port) - ;; Don't print OBJ's external representation: we don't want key material - ;; to leak in backtraces and such. - (format port "#<canonical-sexp ~a | ~a>" - (number->string (object-address obj) 16) - (number->string (pointer-address (canonical-sexp->pointer obj)) - 16)))) - -(define finalize-canonical-sexp! - (libgcrypt-func "gcry_sexp_release")) - -(define-inlinable (pointer->canonical-sexp ptr) - "Return a <canonical-sexp> that wraps PTR." - (let* ((sexp (naked-pointer->canonical-sexp ptr)) - (ptr* (canonical-sexp->pointer sexp))) - ;; Did we already have a <canonical-sexp> object for PTR? - (when (equal? ptr ptr*) - ;; No, so we can safely add a finalizer (in Guile 2.0.9 - ;; 'set-pointer-finalizer!' *adds* a finalizer rather than replacing the - ;; existing one.) - (set-pointer-finalizer! ptr finalize-canonical-sexp!)) - sexp)) - -(define error-source - (let* ((ptr (libgcrypt-func "gcry_strsource")) - (proc (pointer->procedure '* ptr (list int)))) - (lambda (err) - "Return the error source (a string) for ERR, an error code as thrown -along with 'gcry-error'." - (pointer->string (proc err))))) - -(define error-string - (let* ((ptr (libgcrypt-func "gcry_strerror")) - (proc (pointer->procedure '* ptr (list int)))) - (lambda (err) - "Return the error description (a string) for ERR, an error code as -thrown along with 'gcry-error'." - (pointer->string (proc err))))) - -(define string->canonical-sexp - (let* ((ptr (libgcrypt-func "gcry_sexp_new")) - (proc (pointer->procedure int ptr `(* * ,size_t ,int)))) - (lambda (str) - "Parse STR and return the corresponding gcrypt s-expression." - - ;; When STR comes from 'canonical-sexp->string', it may contain - ;; characters that are really meant to be interpreted as bytes as in a C - ;; 'char *'. Thus, convert STR to ISO-8859-1 so the byte values of the - ;; characters are preserved. - (let* ((sexp (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc sexp (string->pointer str "ISO-8859-1") 0 1))) - (if (= 0 err) - (pointer->canonical-sexp (dereference-pointer sexp)) - (throw 'gcry-error 'string->canonical-sexp err)))))) - -(define-syntax GCRYSEXP_FMT_ADVANCED - (identifier-syntax 3)) - -(define canonical-sexp->string - (let* ((ptr (libgcrypt-func "gcry_sexp_sprint")) - (proc (pointer->procedure size_t ptr `(* ,int * ,size_t)))) - (lambda (sexp) - "Return a textual representation of SEXP." - (let loop ((len 1024)) - (let* ((buf (bytevector->pointer (make-bytevector len))) - (size (proc (canonical-sexp->pointer sexp) - GCRYSEXP_FMT_ADVANCED buf len))) - (if (zero? size) - (loop (* len 2)) - (pointer->string buf size "ISO-8859-1"))))))) - -(define (read-file-sexp file) - "Return the canonical sexp read from FILE." - (call-with-input-file file - (compose string->canonical-sexp - read-string))) - -(define canonical-sexp-car - (let* ((ptr (libgcrypt-func "gcry_sexp_car")) - (proc (pointer->procedure '* ptr '(*)))) - (lambda (lst) - "Return the first element of LST, an sexp, if that element is a list; -return #f if LST or its first element is not a list (this is different from -the usual Lisp 'car'.)" - (let ((result (proc (canonical-sexp->pointer lst)))) - (if (null-pointer? result) - #f - (pointer->canonical-sexp result)))))) - -(define canonical-sexp-cdr - (let* ((ptr (libgcrypt-func "gcry_sexp_cdr")) - (proc (pointer->procedure '* ptr '(*)))) - (lambda (lst) - "Return the tail of LST, an sexp, or #f if LST is not a list." - (let ((result (proc (canonical-sexp->pointer lst)))) - (if (null-pointer? result) - #f - (pointer->canonical-sexp result)))))) - -(define canonical-sexp-nth - (let* ((ptr (libgcrypt-func "gcry_sexp_nth")) - (proc (pointer->procedure '* ptr `(* ,int)))) - (lambda (lst index) - "Return the INDEXth nested element of LST, an s-expression. Return #f -if that element does not exist, or if it's an atom. (Note: this is obviously -different from Scheme's 'list-ref'.)" - (let ((result (proc (canonical-sexp->pointer lst) index))) - (if (null-pointer? result) - #f - (pointer->canonical-sexp result)))))) - -(define (dereference-size_t p) - "Return the size_t value pointed to by P." - (bytevector-uint-ref (pointer->bytevector p (sizeof size_t)) - 0 (native-endianness) - (sizeof size_t))) - -(define canonical-sexp-length - (let* ((ptr (libgcrypt-func "gcry_sexp_length")) - (proc (pointer->procedure int ptr '(*)))) - (lambda (sexp) - "Return the length of SEXP if it's a list (including the empty list); -return zero if SEXP is an atom." - (proc (canonical-sexp->pointer sexp))))) - -(define token-string? - (let ((token-cs (char-set-union char-set:digit - char-set:letter - (char-set #\- #\. #\/ #\_ - #\: #\* #\+ #\=)))) - (lambda (str) - "Return #t if STR is a token as per Section 4.3 of -<http://people.csail.mit.edu/rivest/Sexp.txt>." - (and (not (string-null? str)) - (string-every token-cs str) - (not (char-set-contains? char-set:digit (string-ref str 0))))))) - -(define canonical-sexp-nth-data - (let* ((ptr (libgcrypt-func "gcry_sexp_nth_data")) - (proc (pointer->procedure '* ptr `(* ,int *)))) - (lambda (lst index) - "Return as a symbol (for \"sexp tokens\") or a bytevector (for any other -\"octet string\") the INDEXth data element (atom) of LST, an s-expression. -Return #f if that element does not exist, or if it's a list." - (let* ((size* (bytevector->pointer (make-bytevector (sizeof '*)))) - (result (proc (canonical-sexp->pointer lst) index size*))) - (if (null-pointer? result) - #f - (let* ((len (dereference-size_t size*)) - (str (pointer->string result len "ISO-8859-1"))) - ;; The sexp spec speaks of "tokens" and "octet strings". - ;; Sometimes these octet strings are actual strings (text), - ;; sometimes they're bytevectors, and sometimes they're - ;; multi-precision integers (MPIs). Only the application knows. - ;; However, for convenience, we return a symbol when a token is - ;; encountered since tokens are frequent (at least in the 'car' - ;; of each sexp.) - (if (token-string? str) - (string->symbol str) ; an sexp "token" - (bytevector-copy ; application data, textual or binary - (pointer->bytevector result len))))))))) - -(define (number->canonical-sexp number) - "Return an s-expression representing NUMBER." - (string->canonical-sexp (string-append "#" (number->string number 16) "#"))) - -(define* (bytevector->hash-data bv - #:optional - (hash-algo "sha256") - #:key (key-type 'ecc)) - "Given BV, a bytevector containing a hash of type HASH-ALGO, return an -s-expression suitable for use as the 'data' argument for 'sign'. KEY-TYPE -must be a symbol: 'dsa, 'ecc, or 'rsa." - (string->canonical-sexp - (format #f "(data (flags ~a) (hash \"~a\" #~a#))" - (case key-type - ((ecc dsa) "rfc6979") - ((rsa) "pkcs1") - (else (error "unknown key type" key-type))) - hash-algo - (bytevector->base16-string bv)))) - -(define (key-type sexp) - "Return a symbol denoting the type of public or private key represented by -SEXP--e.g., 'rsa', 'ecc'--or #f if SEXP does not denote a valid key." - (case (canonical-sexp-nth-data sexp 0) - ((public-key private-key) - (canonical-sexp-nth-data (canonical-sexp-nth sexp 1) 0)) - (else #f))) - -(define* (hash-data->bytevector data) - "Return two values: the hash value (a bytevector), and the hash algorithm (a -string) extracted from DATA, an sexp as returned by 'bytevector->hash-data'. -Return #f if DATA does not conform." - (let ((hash (find-sexp-token data 'hash))) - (if hash - (let ((algo (canonical-sexp-nth-data hash 1)) - (value (canonical-sexp-nth-data hash 2))) - (values value (symbol->string algo))) - (values #f #f)))) - -(define sign - (let* ((ptr (libgcrypt-func "gcry_pk_sign")) - (proc (pointer->procedure int ptr '(* * *)))) - (lambda (data secret-key) - "Sign DATA, a canonical s-expression representing a suitable hash, with -SECRET-KEY (a canonical s-expression whose car is 'private-key'.) Note that -DATA must be a 'data' s-expression, as returned by -'bytevector->hash-data' (info \"(gcrypt) Cryptographic Functions\")." - (let* ((sig (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc sig (canonical-sexp->pointer data) - (canonical-sexp->pointer secret-key)))) - (if (= 0 err) - (pointer->canonical-sexp (dereference-pointer sig)) - (throw 'gcry-error 'sign err)))))) - -(define verify - (let* ((ptr (libgcrypt-func "gcry_pk_verify")) - (proc (pointer->procedure int ptr '(* * *)))) - (lambda (signature data public-key) - "Verify that SIGNATURE is a signature of DATA with PUBLIC-KEY, all of -which are gcrypt s-expressions." - (zero? (proc (canonical-sexp->pointer signature) - (canonical-sexp->pointer data) - (canonical-sexp->pointer public-key)))))) - -(define generate-key - (let* ((ptr (libgcrypt-func "gcry_pk_genkey")) - (proc (pointer->procedure int ptr '(* *)))) - (lambda (params) - "Return as an s-expression a new key pair for PARAMS. PARAMS must be an -s-expression like: (genkey (rsa (nbits 4:2048)))." - (let* ((key (bytevector->pointer (make-bytevector (sizeof '*)))) - (err (proc key (canonical-sexp->pointer params)))) - (if (zero? err) - (pointer->canonical-sexp (dereference-pointer key)) - (throw 'gcry-error 'generate-key err)))))) - -(define find-sexp-token - (let* ((ptr (libgcrypt-func "gcry_sexp_find_token")) - (proc (pointer->procedure '* ptr `(* * ,size_t)))) - (lambda (sexp token) - "Find in SEXP the first element whose 'car' is TOKEN and return it; -return #f if not found." - (let* ((token (string->pointer (symbol->string token))) - (res (proc (canonical-sexp->pointer sexp) token 0))) - (if (null-pointer? res) - #f - (pointer->canonical-sexp res)))))) - -(define-inlinable (canonical-sexp-null? sexp) - "Return #t if SEXP is the empty-list sexp." - (null-pointer? (canonical-sexp->pointer sexp))) - -(define (canonical-sexp-list? sexp) - "Return #t if SEXP is a list." - (or (canonical-sexp-null? sexp) - (> (canonical-sexp-length sexp) 0))) - -(define (canonical-sexp-fold proc seed sexp) - "Fold PROC (as per SRFI-1) over SEXP, a canonical sexp." - (if (canonical-sexp-list? sexp) - (let ((len (canonical-sexp-length sexp))) - (let loop ((index 0) - (result seed)) - (if (= index len) - result - (loop (+ 1 index) - ;; XXX: Call 'nth-data' *before* 'nth' to work around - ;; <https://bugs.g10code.com/gnupg/issue1594>, which - ;; affects 1.6.0 and earlier versions. - (proc (or (canonical-sexp-nth-data sexp index) - (canonical-sexp-nth sexp index)) - result))))) - (error "sexp is not a list" sexp))) - -(define (canonical-sexp->sexp sexp) - "Return a Scheme sexp corresponding to SEXP. This is particularly useful to -compare sexps (since Libgcrypt does not provide an 'equal?' procedure), or to -use pattern matching." - (if (canonical-sexp-list? sexp) - (reverse - (canonical-sexp-fold (lambda (item result) - (cons (if (canonical-sexp? item) - (canonical-sexp->sexp item) - item) - result)) - '() - sexp)) - - ;; As of Libgcrypt 1.6.0, there's no function to extract the buffer of a - ;; non-list sexp (!), so we first enlist SEXP, then get at its buffer. - (let ((sexp (string->canonical-sexp - (string-append "(" (canonical-sexp->string sexp) - ")")))) - (or (canonical-sexp-nth-data sexp 0) - (canonical-sexp-nth sexp 0))))) - -(define (sexp->canonical-sexp sexp) - "Return a canonical sexp equivalent to SEXP, a Scheme sexp as returned by -'canonical-sexp->sexp'." - ;; XXX: This is inefficient, but the Libgcrypt API doesn't allow us to do - ;; much better. - (string->canonical-sexp - (call-with-output-string - (lambda (port) - (define (write item) - (cond ((list? item) - (display "(" port) - (for-each write item) - (display ")" port)) - ((symbol? item) - (format port " ~a" item)) - ((bytevector? item) - (format port " #~a#" - (bytevector->base16-string item))) - (else - (error "unsupported sexp item type" item)))) - - (write sexp))))) - -(define (gcrypt-error-printer port key args default-printer) - "Print the gcrypt error specified by ARGS." - (match args - ((proc err) - (format port "In procedure ~a: ~a: ~a" - proc (error-source err) (error-string err))))) - -(set-exception-printer! 'gcry-error gcrypt-error-printer) - -;;; pk-crypto.scm ends here diff --git a/guix/pki.scm b/guix/pki.scm index 1551425c33..6326e065e9 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -18,7 +18,7 @@ (define-module (guix pki) #:use-module (guix config) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module ((guix utils) #:select (with-atomic-file-output)) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) diff --git a/guix/profiles.scm b/guix/profiles.scm index f34f4fcff6..ba4446bc2f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -28,7 +28,8 @@ #:use-module ((guix config) #:select (%state-directory)) #:use-module ((guix utils) #:hide (package-name->name+version)) #:use-module ((guix build utils) - #:select (package-name->name+version)) + #:select (package-name->name+version mkdir-p)) + #:use-module (guix i18n) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix derivations) @@ -55,7 +56,7 @@ profile-error-profile &profile-not-found-error profile-not-found-error? - &profile-collistion-error + &profile-collision-error profile-collision-error? profile-collision-error-entry profile-collision-error-conflict @@ -127,6 +128,7 @@ %user-profile-directory %profile-directory %current-profile + ensure-profile-directory canonicalize-profile user-friendly-profile)) @@ -286,7 +288,8 @@ file name." (manifest-transitive-entries manifest)))) (define* (package->manifest-entry package #:optional (output "out") - #:key (parent (delay #f))) + #:key (parent (delay #f)) + (properties '())) "Return a manifest entry for the OUTPUT of package PACKAGE." ;; For each dependency, keep a promise pointing to its "parent" entry. (letrec* ((deps (map (match-lambda @@ -305,19 +308,39 @@ file name." (dependencies (delete-duplicates deps)) (search-paths (package-transitive-native-search-paths package)) - (parent parent)))) + (parent parent) + (properties properties)))) entry)) (define (packages->manifest packages) "Return a list of manifest entries, one for each item listed in PACKAGES. Elements of PACKAGES can be either package objects or package/string tuples denoting a specific output of a package." + (define inferiors-loaded? + ;; This hack allows us to provide seamless integration for inferior + ;; packages while not having a hard dependency on (guix inferior). + (resolve-module '(guix inferior) #f #f #:ensure #f)) + + (define (inferior->entry) + (module-ref (resolve-interface '(guix inferior)) + 'inferior-package->manifest-entry)) + (manifest (map (match-lambda - ((package output) - (package->manifest-entry package output)) - ((? package? package) - (package->manifest-entry package))) + ((package output) + (package->manifest-entry package output)) + ((? package? package) + (package->manifest-entry package)) + ((thing output) + (if inferiors-loaded? + ((inferior->entry) thing output) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing)))) + (thing + (if inferiors-loaded? + ((inferior->entry) thing) + (throw 'wrong-type-arg 'packages->manifest + "Wrong package object: ~S" (list thing) (list thing))))) packages))) (define (manifest->gexp manifest) @@ -1228,7 +1251,7 @@ the entries in MANIFEST." (define config.scm (scheme-file "config.scm" #~(begin - (define-module (guix config) + (define-module #$'(guix config) ;placate Geiser #:export (%libz)) (define %libz @@ -1589,28 +1612,73 @@ because the NUMBER is zero.)" ;; coexist with Nix profiles. (string-append %profile-directory "/guix-profile")) -(define (canonicalize-profile profile) - "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE. Otherwise -return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' as if -'-p' was omitted." ; see <http://bugs.gnu.org/17939> +(define (ensure-profile-directory) + "Attempt to create /…/profiles/per-user/$USER if needed." + (let ((s (stat %profile-directory #f))) + (unless (and s (eq? 'directory (stat:type s))) + (catch 'system-error + (lambda () + (mkdir-p %profile-directory)) + (lambda args + ;; Often, we cannot create %PROFILE-DIRECTORY because its + ;; parent directory is root-owned and we're running + ;; unprivileged. + (raise (condition + (&message + (message + (format #f + (G_ "while creating directory `~a': ~a") + %profile-directory + (strerror (system-error-errno args))))) + (&fix-hint + (hint + (format #f (G_ "Please create the @file{~a} directory, \ +with you as the owner.") + %profile-directory)))))))) + + ;; Bail out if it's not owned by the user. + (unless (or (not s) (= (stat:uid s) (getuid))) + (raise (condition + (&message + (message + (format #f (G_ "directory `~a' is not owned by you") + %profile-directory))) + (&fix-hint + (hint + (format #f (G_ "Please change the owner of @file{~a} \ +to user ~s.") + %profile-directory (or (getenv "USER") + (getenv "LOGNAME") + (getuid)))))))))) - ;; Trim trailing slashes so that the basename comparison below works as - ;; intended. +(define (canonicalize-profile profile) + "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that. +Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile' +as if '-p' was omitted." ; see <http://bugs.gnu.org/17939> + ;; Trim trailing slashes so 'readlink' can do its job. (let ((profile (string-trim-right profile #\/))) - (if (and %user-profile-directory - (string=? (canonicalize-path (dirname profile)) - (dirname %user-profile-directory)) - (string=? (basename profile) (basename %user-profile-directory))) - %current-profile - profile))) + (catch 'system-error + (lambda () + (let ((target (readlink profile))) + (if (string=? (dirname target) %profile-directory) + target + profile))) + (const profile)))) + +(define %known-shorthand-profiles + ;; Known shorthand forms for profiles that the user manipulates. + (list (string-append (config-directory #:ensure? #f) "/current") + %user-profile-directory)) (define (user-friendly-profile profile) - "Return either ~/.guix-profile if that's what PROFILE refers to, directly or -indirectly, or PROFILE." - (if (and %user-profile-directory - (false-if-exception - (string=? (readlink %user-profile-directory) profile))) - %user-profile-directory + "Return either ~/.guix-profile or ~/.config/guix/current if that's what +PROFILE refers to, directly or indirectly, or PROFILE." + (or (find (lambda (shorthand) + (and shorthand + (let ((target (false-if-exception + (readlink shorthand)))) + (and target (string=? target profile))))) + %known-shorthand-profiles) profile)) ;;; profiles.scm ends here diff --git a/guix/progress.scm b/guix/progress.scm index c9c3cd12a0..65080bcf24 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> -;;; 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. ;;; @@ -38,7 +39,11 @@ progress-reporter/silent progress-reporter/file progress-reporter/bar + progress-reporter/trace + display-download-progress + erase-current-line + progress-bar byte-count->string current-terminal-columns @@ -70,11 +75,11 @@ stopped." (($ <progress-reporter> start report stop) (start)))) -(define (progress-reporter-report! reporter) +(define (progress-reporter-report! reporter . args) "Low-level procedure to lead REPORTER to emit a report." (match reporter (($ <progress-reporter> start report stop) - (report)))) + (apply report args)))) (define (stop-progress-reporter! reporter) "Low-level procedure to stop REPORTER." @@ -183,6 +188,49 @@ width of the bar is BAR-WIDTH." move the cursor to the beginning of the line." (display "\r\x1b[K" port)) +(define* (display-download-progress file size + #:key + start-time (transferred 0) + (log-port (current-error-port))) + "Write the progress report to LOG-PORT. Use START-TIME (a SRFI-19 time +object) and TRANSFERRED (a total number of bytes) to determine the +throughput." + (define elapsed + (duration->seconds + (time-difference (current-time time-monotonic) start-time))) + (if (and (number? size) (not (zero? size))) + (let* ((% (* 100.0 (/ transferred size))) + (throughput (/ transferred elapsed)) + (left (format #f " ~a ~a" file + (byte-count->string size))) + (right (format #f "~a/s ~a ~a~6,1f%" + (byte-count->string throughput) + (seconds->string elapsed) + (progress-bar %) %))) + (erase-current-line log-port) + (display (string-pad-middle left right + (current-terminal-columns)) + log-port) + (force-output log-port)) + ;; If we don't know the total size, the last transfer will have a 0B + ;; size. Don't display it. + (unless (zero? transferred) + (let* ((throughput (/ transferred elapsed)) + (left (format #f " ~a" file)) + (right (format #f "~a/s ~a | ~a transferred" + (byte-count->string throughput) + (seconds->string elapsed) + (byte-count->string transferred)))) + (erase-current-line log-port) + (display (string-pad-middle left right + (current-terminal-columns)) + log-port) + (force-output log-port))))) + +(define %progress-interval + ;; Default interval between subsequent outputs for rate-limited displays. + (make-time time-monotonic 200000000 0)) + (define* (progress-reporter/file file size #:optional (log-port (current-output-port)) #:key (abbreviation basename)) @@ -192,44 +240,16 @@ ABBREVIATION used to shorten FILE for display." (let ((start-time (current-time time-monotonic)) (transferred 0)) (define (render) - "Write the progress report to LOG-PORT." - (define elapsed - (duration->seconds - (time-difference (current-time time-monotonic) start-time))) - (if (number? size) - (let* ((% (* 100.0 (/ transferred size))) - (throughput (/ transferred elapsed)) - (left (format #f " ~a ~a" - (abbreviation file) - (byte-count->string size))) - (right (format #f "~a/s ~a ~a~6,1f%" - (byte-count->string throughput) - (seconds->string elapsed) - (progress-bar %) %))) - (erase-current-line log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (force-output log-port)) - (let* ((throughput (/ transferred elapsed)) - (left (format #f " ~a" - (abbreviation file))) - (right (format #f "~a/s ~a | ~a transferred" - (byte-count->string throughput) - (seconds->string elapsed) - (byte-count->string transferred)))) - (erase-current-line log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (force-output log-port)))) + (display-download-progress (abbreviation file) size + #:start-time start-time + #:transferred transferred + #:log-port log-port)) (progress-reporter (start render) ;; Report the progress every 300ms or longer. (report - (let ((rate-limited-render - (rate-limited render (make-time time-monotonic 300000000 0)))) + (let ((rate-limited-render (rate-limited render %progress-interval))) (lambda (value) (set! transferred value) (rate-limited-render)))) @@ -269,6 +289,37 @@ tasks is performed. Write PREFIX at the beginning of the line." (newline port)) (force-output port))))) +(define* (progress-reporter/trace file url size + #:optional (log-port (current-output-port))) + "Like 'progress-reporter/file', but instead of returning human-readable +progress reports, write \"build trace\" lines to be processed elsewhere." + (define total 0) ;bytes transferred + + (define (report-progress transferred) + (define message + (format #f "@ download-progress ~a ~a ~a ~a~%" + file url (or size "-") transferred)) + + (display message log-port) ;should be atomic + (flush-output-port log-port)) + + (progress-reporter + (start (lambda () + (set! total 0) + (display (format #f "@ download-started ~a ~a ~a~%" + file url (or size "-")) + log-port))) + (report (let ((report (rate-limited report-progress %progress-interval))) + (lambda (transferred) + (set! total transferred) + (report transferred)))) + (stop (lambda () + (let ((size (or size total))) + (report-progress size) + (display (format #f "@ download-succeeded ~a ~a ~a~%" + file url size) + log-port)))))) + ;; TODO: replace '(@ (guix build utils) dump-port))'. (define* (dump-port* in out #:key (buffer-size 16384) diff --git a/guix/records.scm b/guix/records.scm index da3ecdaaf8..98f3c8fef0 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -52,17 +52,6 @@ ((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. @@ -81,7 +70,11 @@ 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))))) + ;; The source file where this exception is thrown must be + ;; recompiled. + (throw 'record-abi-mismatch-error 'abi-check + "~a: record ABI mismatch; recompilation needed" + (list #,type) '()))))) (define-syntax make-syntactic-constructor (syntax-rules () diff --git a/guix/scripts.scm b/guix/scripts.scm index 4cbbbeb96f..5e20ecd92c 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -26,6 +26,8 @@ #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) + #:use-module ((guix profiles) #:select (%profile-directory)) + #:use-module (guix build syscalls) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-37) @@ -36,7 +38,9 @@ build-package build-package-source %distro-age-warning - warn-about-old-distro)) + warn-about-old-distro + %disk-space-warning + warn-about-disk-space)) ;;; Commentary: ;;; @@ -169,8 +173,7 @@ Show what and how will/would be built." (define age (match (false-if-not-found - (lstat (string-append (config-directory #:ensure? #f) - "/current"))) + (lstat (string-append %profile-directory "/current-guix"))) (#f #f) (stat (- (time-second (current-time time-utc)) (stat:mtime stat))))) @@ -186,4 +189,37 @@ Show what and how will/would be built." suggested-command) (newline (guix-warning-port))))) +(define %disk-space-warning + ;; The fraction (between 0 and 1) of free disk space below which a warning + ;; is emitted. + (make-parameter (match (and=> (getenv "GUIX_DISK_SPACE_WARNING") + string->number) + (#f .05) ;5% + (threshold (/ threshold 100.))))) + +(define* (warn-about-disk-space #:optional profile + #:key + (threshold (%disk-space-warning))) + "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is +available." + (let* ((stats (statfs (%store-prefix))) + (block-size (file-system-block-size stats)) + (available (* block-size (file-system-blocks-available stats))) + (total (* block-size (file-system-block-count stats))) + (ratio (/ available total 1.))) + (when (< ratio threshold) + (warning (G_ "only ~,1f% of free space available on ~a~%") + (* ratio 100) (%store-prefix)) + (if profile + (display-hint (format #f (G_ "Consider deleting old profile +generations and collecting garbage, along these lines: + +@example +guix package -p ~s --delete-generations=1m +guix gc +@end example\n") + profile)) + (display-hint (G_ "Consider running @command{guix gc} to free +space.")))))) + ;;; scripts.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index a359f405fe..fb2f61ce30 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -29,7 +29,7 @@ #:use-module (guix monads) #:use-module (guix ui) #:use-module (guix pki) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 8b19dc871b..f1fd8ee895 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -19,7 +19,7 @@ (define-module (guix scripts authenticate) #:use-module (guix config) #:use-module (guix base16) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix ui) #:use-module (ice-9 binary-ports) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4dd4fbccdf..5532c65eb6 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,11 @@ #:use-module (srfi srfi-37) #:autoload (gnu packages) (specification->package %package-module-path) #:autoload (guix download) (download-to-store) + #:autoload (guix git-download) (git-reference?) + #:autoload (guix git) (git-checkout?) + #:use-module (guix status) + #:use-module ((guix progress) #:select (current-terminal-columns)) + #:use-module ((guix build syscalls) #:select (terminal-columns)) #:export (%standard-build-options set-build-options-from-command-line set-build-options-from-command-line* @@ -267,6 +272,74 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (rewrite obj) obj)))) +(define (evaluate-git-replacement-specs specs proc) + "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list +of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the +replacement package. Raise an error if an element of SPECS uses invalid +syntax, or if a package it refers to could not be found." + (define not-equal + (char-set-complement (char-set #\=))) + + (map (lambda (spec) + (match (string-tokenize spec not-equal) + ((name branch-or-commit) + (let* ((old (specification->package name)) + (source (package-source old)) + (url (cond ((and (origin? source) + (git-reference? (origin-uri source))) + (git-reference-url (origin-uri source))) + ((git-checkout? source) + (git-checkout-url source)) + (else + (leave (G_ "the source of ~a is not a Git \ +reference~%") + (package-full-name old)))))) + (cons old (proc old url branch-or-commit)))) + (x + (leave (G_ "invalid replacement specification: ~s~%") spec)))) + specs)) + +(define (transform-package-source-branch replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=stable-3.0\" meaning that packages are built using +'guile-next' from the latest commit on its 'stable-3.0' branch." + (define (replace old url branch) + (package + (inherit old) + (version (string-append "git." branch)) + (source (git-checkout (url url) (branch branch))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-source-commit replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=cabba9e\" meaning that packages are built using +'guile-next' from commit 'cabba9e'." + (define (replace old url commit) + (package + (inherit old) + (version (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7)))) + (source (git-checkout (url url) (commit commit))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -274,7 +347,9 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." ;; things to build. `((with-source . ,transform-package-source) (with-input . ,transform-package-inputs) - (with-graft . ,transform-package-inputs/graft))) + (with-graft . ,transform-package-inputs/graft) + (with-branch . ,transform-package-source-branch) + (with-commit . ,transform-package-source-commit))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -288,7 +363,11 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (option '("with-input") #t #f (parser 'with-input)) (option '("with-graft") #t #f - (parser 'with-graft))))) + (parser 'with-graft)) + (option '("with-branch") #t #f + (parser 'with-branch)) + (option '("with-commit") #t #f + (parser 'with-commit))))) (define (show-transformation-options-help) (display (G_ " @@ -299,7 +378,13 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." replace dependency PACKAGE by REPLACEMENT")) (display (G_ " --with-graft=PACKAGE=REPLACEMENT - graft REPLACEMENT on packages that refer to PACKAGE"))) + graft REPLACEMENT on packages that refer to PACKAGE")) + (display (G_ " + --with-branch=PACKAGE=BRANCH + build PACKAGE from the latest commit of BRANCH")) + (display (G_ " + --with-commit=PACKAGE=COMMIT + build PACKAGE from COMMIT"))) (define (options->transformation opts) @@ -390,6 +475,10 @@ options handled by 'set-build-options-from-command-line', and listed in #:max-silent-time (assoc-ref opts 'max-silent-time) #:timeout (assoc-ref opts 'timeout) #:print-build-trace (assoc-ref opts 'print-build-trace?) + #:print-extended-build-trace? + (assoc-ref opts 'print-extended-build-trace?) + #:multiplexed-build-output? + (assoc-ref opts 'multiplexed-build-output?) #:verbosity (assoc-ref opts 'verbosity))) (define set-build-options-from-command-line* @@ -499,6 +588,8 @@ options handled by 'set-build-options-from-command-line', and listed in (substitutes? . #t) (build-hook? . #t) (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (show-help) @@ -617,7 +708,7 @@ must be one of 'package', 'all', or 'transitive'~%") "Read the arguments from OPTS and return a list of high-level objects to build---packages, gexps, derivations, and so on." (define (validate-type x) - (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) + (unless (or (derivation? x) (file-like? x) (gexp? x) (procedure? x)) (leave (G_ "~s: not something we can build~%") x))) (define (ensure-list x) @@ -694,6 +785,10 @@ package '~a' has no source~%") (set-guile-for-build (default-guile)) (proc)) #:system system))) + ((? file-like? obj) + (list (run-with-store store + (lower-object obj system + #:target (assoc-ref opts 'target))))) ((? gexp? gexp) (list (run-with-store store (mbegin %store-monad @@ -733,9 +828,12 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-build-output-port (if quiet? - (%make-void-port "w") - (current-error-port)))) + (parameterize ((current-terminal-columns (terminal-columns)) + (current-build-output-port + (if quiet? + (%make-void-port "w") + (build-event-output-port + (build-status-updater print-build-event))))) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm new file mode 100644 index 0000000000..f21311af09 --- /dev/null +++ b/guix/scripts/describe.scm @@ -0,0 +1,208 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts describe) + #:use-module ((guix ui) #:hide (display-profile-content)) + #:use-module (guix channels) + #:use-module (guix scripts) + #:use-module (guix describe) + #:use-module (guix profiles) + #:use-module ((guix scripts pull) #:select (display-profile-content)) + #:use-module (git) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:autoload (ice-9 pretty-print) (pretty-print) + #:export (guix-describe)) + + +;;; +;;; Command-line options. +;;; + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (unless (member arg '("human" "channels" "json" "recutils")) + (leave (G_ "~a: unsupported output format~%") arg)) + (alist-cons 'format (string->symbol arg) result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile (canonicalize-profile arg) + result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix describe"))))) + +(define %default-options + ;; Alist of default option values. + '((format . human))) + +(define (show-help) + (display (G_ "Usage: guix describe [OPTION]... +Display information about the channels currently in use.\n")) + (display (G_ " + -f, --format=FORMAT display information in the given FORMAT")) + (display (G_ " + -p, --profile=PROFILE display information about PROFILE")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (display-package-search-path fmt) + "Display GUIX_PACKAGE_PATH, if it is set, according to FMT." + (match (getenv "GUIX_PACKAGE_PATH") + (#f #t) + (string + (match fmt + ('human + (format #t "~%GUIX_PACKAGE_PATH=\"~a\"~%" string)) + ('channels + (format #t (G_ "~%;; warning: GUIX_PACKAGE_PATH=\"~a\"~%") + string)))))) + +(define (channel->sexp channel) + `(channel + (name ,(channel-name channel)) + (url ,(channel-url channel)) + (commit ,(channel-commit channel)))) + +(define (channel->json channel) + (scm->json-string `((name . ,(channel-name channel)) + (url . ,(channel-url channel)) + (commit . ,(channel-commit channel))))) + +(define (channel->recutils channel port) + (format port "name: ~a~%" (channel-name channel)) + (format port "url: ~a~%" (channel-url channel)) + (format port "commit: ~a~%" (channel-commit channel))) + +(define (display-checkout-info fmt) + "Display information about the current checkout according to FMT, a symbol +denoting the requested format. Exit if the current directory does not lie +within a Git checkout." + (let* ((program (car (command-line))) + (directory (catch 'git-error + (lambda () + (repository-discover (dirname program))) + (lambda (key err) + (leave (G_ "failed to determine origin~%"))))) + (repository (repository-open directory)) + (head (repository-head repository)) + (commit (oid->string (reference-target head)))) + (match fmt + ('human + (format #t (G_ "Git checkout:~%")) + (format #t (G_ " repository: ~a~%") (dirname directory)) + (format #t (G_ " branch: ~a~%") (reference-shorthand head)) + (format #t (G_ " commit: ~a~%") commit)) + ('channels + (pretty-print `(list ,(channel->sexp (channel (name 'guix) + (url (dirname directory)) + (commit commit)))))) + ('json + (display (channel->json (channel (name 'guix) + (url (dirname directory)) + (commit commit)))) + (newline)) + ('recutils + (channel->recutils (channel (name 'guix) + (url (dirname directory)) + (commit commit)) + (current-output-port)))) + (display-package-search-path fmt))) + +(define (display-profile-info profile fmt) + "Display information about PROFILE, a profile as created by (guix channels), +in the format specified by FMT." + (define number + (generation-number profile)) + + (define channels + (map (lambda (entry) + (match (assq 'source (manifest-entry-properties entry)) + (('source ('repository ('version 0) + ('url url) + ('branch branch) + ('commit commit) + _ ...)) + (channel (name (string->symbol (manifest-entry-name entry))) + (url url) + (commit commit))) + + ;; Pre-0.15.0 Guix does not provide that information, + ;; so there's not much we can do in that case. + (_ (channel (name 'guix) + (url "?") + (commit "?"))))) + + ;; Show most recently installed packages last. + (reverse + (manifest-entries + (profile-manifest + (if (zero? number) + profile + (generation-file-name profile number))))))) + + (match fmt + ('human + (display-profile-content profile number)) + ('channels + (pretty-print `(list ,@(map channel->sexp channels)))) + ('json + (format #t "[~a]~%" (string-join (map channel->json channels) ","))) + ('recutils + (format #t "~{~a~%~}" + (map (lambda (channel) + (with-output-to-string + (lambda () + (channel->recutils channel (current-output-port))))) + channels)))) + (display-package-search-path fmt)) + + +;;; +;;; Entry point. +;;; + +(define (guix-describe . args) + (let* ((opts (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") + name)) + cons + %default-options)) + (format (assq-ref opts 'format)) + (profile (or (assq-ref opts 'profile) (current-profile)))) + (with-error-handling + (match profile + (#f + (display-checkout-info format)) + (profile + (display-profile-info (canonicalize-profile profile) format)))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 1b99bc62cf..b9162d3449 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -20,7 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix store) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base16) #:use-module (guix base32) #:use-module ((guix download) #:hide (url-fetch)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1c04800e42..5965e3426e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -21,6 +21,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) @@ -173,6 +174,9 @@ COMMAND or an interactive shell in that environment.\n")) (substitutes? . #t) (build-hook? . #t) (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0))) (define (tag-package-arg opts arg) @@ -661,59 +665,60 @@ message if any test fails." (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (set-build-options-from-command-line store opts) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (derivation->output-path prof-drv)) - (gc-root -> (assoc-ref opts 'gc-root))) - - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (build-environment (if (derivation? bash) - (list prof-drv bash) - (list prof-drv)) - opts) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - bash - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:link-profile? link-prof? - #:network? network?))) - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:pure? pure?))))))))))))) + (with-status-report print-build-event + (set-build-options-from-command-line store opts) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (manifest->derivation + manifest system bootstrap?)) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (build-environment (if (derivation? bash) + (list prof-drv bash) + (list prof-drv)) + opts) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + bash + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:link-profile? link-prof? + #:network? network?))) + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:pure? pure?)))))))))))))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 346ca4ea88..145a574dba 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -439,6 +439,10 @@ package modules, while attempting to retain user package modules." (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -462,6 +466,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) --list-types list the available graph types")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) + (display (G_ " + -s, --system=SYSTEM consider the graph for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -472,7 +478,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define %default-options `((node-type . ,%package-node-type) - (backend . ,%graphviz-backend))) + (backend . ,%graphviz-backend) + (system . ,(%current-system)))) ;;; @@ -508,7 +515,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (export-graph (concatenate nodes) (current-output-port) #:node-type type - #:backend backend))))))) + #:backend backend)) + #:system (assq-ref opts 'system)))))) #t) ;;; graph.scm ends here diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index cae5d6bcdf..b8b2158195 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +21,7 @@ (define-module (guix scripts hash) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix scripts) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 30ae6d4342..794fb710cd 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -47,6 +47,8 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) diff --git a/guix/scripts/import/pypi.scm b/guix/scripts/import/pypi.scm index 59a925a3ca..7bd83818ba 100644 --- a/guix/scripts/import/pypi.scm +++ b/guix/scripts/import/pypi.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-pypi)) @@ -43,6 +45,8 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -56,6 +60,9 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import pypi"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -81,11 +88,22 @@ Import and convert the PyPI package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (pypi->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (pypi-recursive-import package-name)))) + ;; Single import + (let ((sexp (pypi->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/stackage.scm b/guix/scripts/import/stackage.scm index e6676e93e8..b4b12581bf 100644 --- a/guix/scripts/import/stackage.scm +++ b/guix/scripts/import/stackage.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-stackage)) @@ -43,11 +45,13 @@ (display (G_ "Usage: guix import stackage PACKAGE-NAME Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (display (G_ " - -r VERSION, --lts-version=VERSION + -l VERSION, --lts-version=VERSION specify the LTS version to use")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -t, --no-test-dependencies don't include test-only dependencies")) (display (G_ " -V, --version display version information and exit")) @@ -68,11 +72,14 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (alist-cons 'include-test-dependencies? #f (alist-delete 'include-test-dependencies? result)))) - (option '(#\r "lts-version") #t #f + (option '(#\l "lts-version") #t #f (lambda (opt name arg result) (alist-cons 'lts-version arg (alist-delete 'lts-version result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -90,6 +97,27 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (alist-cons 'argument arg result)) %default-options)) + (define (run-importer package-name opts error-fn) + (let* ((arguments (list + package-name + #:include-test-dependencies? + (assoc-ref opts 'include-test-dependencies?) + #:lts-version (assoc-ref opts 'lts-version))) + (sexp (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (apply stackage-recursive-import arguments)))) + ;; Single import + (apply stackage->guix-package arguments)))) + (unless sexp (error-fn)) + sexp)) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) @@ -99,15 +127,11 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) (match args ((package-name) (with-error-handling - (let ((sexp (stackage->guix-package - package-name - #:include-test-dependencies? - (assoc-ref opts 'include-test-dependencies?) - #:lts-version (assoc-ref opts 'lts-version)))) - (unless sexp - (leave (G_ "failed to download cabal file for package '~a'~%") - package-name)) - sexp))) + (run-importer package-name opts + (lambda () + (leave (G_ "failed to download cabal file \ +for package '~a'~%") + package-name))))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e477bf0ddc..2314f3b28c 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -33,6 +33,7 @@ #:use-module (guix packages) #:use-module (guix licenses) #:use-module (guix records) + #:use-module (guix grafts) #:use-module (guix ui) #:use-module (guix upstream) #:use-module (guix utils) @@ -774,30 +775,37 @@ descriptions maintained upstream." (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." - (catch #t - (lambda () - (guard (c ((nix-protocol-error? c) - (emit-warning package - (format #f (G_ "failed to create derivation: ~a") - (nix-protocol-error-message c)))) - ((message-condition? c) - (emit-warning package - (format #f (G_ "failed to create derivation: ~a") - (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (package-derivation store package #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement #:graft? #f)))))) - (lambda args - (emit-warning package - (format #f (G_ "failed to create derivation: ~s~%") - args))))) + (define (try system) + (catch #t + (lambda () + (guard (c ((nix-protocol-error? c) + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~a") + system + (nix-protocol-error-message c)))) + ((message-condition? c) + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~a") + system + (condition-message c))))) + (with-store store + ;; Disable grafts since it can entail rebuilds. + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f))))))) + (lambda args + (emit-warning package + (format #f (G_ "failed to create ~a derivation: ~s") + system args))))) + + (for-each try (package-supported-systems package))) (define (check-license package) "Warn about type errors of the 'license' field of PACKAGE." diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 729850839b..98b06971bd 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> +;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix modules) @@ -37,11 +39,11 @@ #:use-module ((guix self) #:select (make-config.scm)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) - #:use-module (gnu packages compression) + #:use-module ((gnu packages compression) #:hide (zip)) #:use-module (gnu packages guile) #:use-module (gnu packages base) #:autoload (gnu packages package-management) (guix) - #:autoload (gnu packages gnupg) (libgcrypt) + #:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -51,6 +53,9 @@ #:export (compressor? lookup-compressor self-contained-tarball + docker-image + squashfs-image + guix-pack)) ;; Type of a compression tool. @@ -95,13 +100,57 @@ found." (('gnu _ ...) #t) (_ #f))) -(define guile-sqlite3&co - ;; Guile-SQLite3 and its propagated inputs. - (cons guile-sqlite3 - (package-transitive-propagated-inputs guile-sqlite3))) +(define gcrypt-sqlite3&co + ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. + (append-map (lambda (package) + (cons package + (package-transitive-propagated-inputs package))) + (list guile-gcrypt guile-sqlite3))) + +(define (store-database items) + "Return a directory containing a store database where all of ITEMS and their +dependencies are registered." + (define schema + (local-file (search-path %load-path + "guix/store/schema.sql"))) + + + (define labels + (map (lambda (n) + (string-append "closure" (number->string n))) + (iota (length items)))) + + (define build + (with-extensions gcrypt-sqlite3&co + ;; XXX: Adding (gnu build install) just to work around + ;; <https://bugs.gnu.org/15602>: that way, (guix build store-copy) is + ;; copied last and the 'store-info-XXX' macros are correctly expanded. + (with-imported-modules (source-module-closure + '((guix build store-copy) + (guix store database) + (gnu build install))) + #~(begin + (use-modules (guix store database) + (guix build store-copy) + (srfi srfi-1)) + + (define (read-closure closure) + (call-with-input-file closure read-reference-graph)) + + (let ((items (append-map read-closure '#$labels))) + (register-items items + #:state-directory #$output + #:deduplicate? #f + #:reset-timestamps? #f + #:registration-time %epoch + #:schema #$schema)))))) + + (computed-file "store-database" build + #:options `(#:references-graphs ,(zip labels items)))) (define* (self-contained-tarball name profile #:key target + (profile-name "guix-profile") deduplicate? (compressor (first %compressors)) localstatedir? @@ -114,124 +163,117 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define libgcrypt - (module-ref (resolve-interface '(gnu packages gnupg)) - 'libgcrypt)) - - (define schema + (define database (and localstatedir? - (local-file (search-path %load-path - "guix/store/schema.sql")))) + (file-append (store-database (list profile)) + "/db/db.sqlite"))) (define build - (with-imported-modules `(((guix config) - => ,(make-config.scm - #:libgcrypt libgcrypt)) - ,@(source-module-closure - `((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions guile-sqlite3&co - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; 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. - (append-map symlink->directives '#$symlinks)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 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 #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; Add 'tar' to the search path. - (setenv "PATH" #+(file-append 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. - ;; 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" - #:deduplicate? #f - #:register? #$localstatedir? - #:schema #$schema) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - "-I" - (string-join '#+(compressor-command compressor)) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))))) + (with-imported-modules (source-module-closure + `((guix build utils) + (guix build union) + (gnu build install)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; 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. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 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 #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append 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. + ;; 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 + #:profile-name #$profile-name + #:closure "profile" + #:database #+database) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + #+@(if (compressor-command compressor) + #~("-I" + (string-join + '#+(compressor-command compressor))) + #~()) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -240,7 +282,7 @@ added to the pack." (define* (squashfs-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -251,83 +293,85 @@ 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 libgcrypt - ;; XXX: Not strictly needed, but pulled by (guix store database). - (module-ref (resolve-interface '(gnu packages gnupg)) - 'libgcrypt)) - + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) (define build - (with-imported-modules `(((guix config) - => ,(make-config.scm - #:libgcrypt libgcrypt)) - ,@(source-module-closure - '((guix build utils) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions guile-sqlite3&co - #~(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")) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build store-copy) + (gnu build install)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + (guix build store-copy) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) - ;; 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" - `(,@(map store-info-item - (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")))))) + (define database #+database) + + (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" + `(,@(map store-info-item + (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")) + + (when database + ;; Initialize /var/guix. + (install-database-and-gc-roots "var-etc" database #$profile) + (invoke "mksquashfs" "var-etc" #$output))))) (gexp->derivation (string-append name (compressor-extension compressor) @@ -337,7 +381,7 @@ added to the pack." (define* (docker-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -347,34 +391,19 @@ 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 must a be a GNU triplet and it is used to derive the architecture metadata in the image." - (define defmod 'define-module) ;trick Geiser + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) - (define config - ;; (guix config) module for consumption by (guix gcrypt). - (scheme-file "gcrypt-config.scm" - #~(begin - (#$defmod (guix config) - #:export (%libgcrypt)) - - ;; XXX: Work around <http://bugs.gnu.org/15602>. - (eval-when (expand load eval) - (define %libgcrypt - #+(file-append libgcrypt "/lib/libgcrypt")))))) - - (define json - ;; Pick the guile-json package that corresponds to the Guile used to build - ;; derivations. - (if (string-prefix? "2.0" (package-version (default-guile))) - guile2.0-json - guile-json)) + (define defmod 'define-module) ;trick Geiser (define build - ;; Guile-JSON is required by (guix docker). - (with-extensions (list json) - (with-imported-modules `(,@(source-module-closure '((guix docker) - (guix build store-copy)) - #:select? not-config?) - ((guix config) => ,config)) + ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). + (with-extensions (list guile-json guile-gcrypt) + (with-imported-modules (source-module-closure '((guix docker) + (guix build store-copy)) + #:select? not-config?) #~(begin (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) @@ -385,6 +414,7 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile + #:database #+database #:system (or #$target (utsname:machine (uname))) #:symlinks '#$symlinks #:compressor '#$(compressor-command compressor) @@ -562,10 +592,14 @@ please email '~a'~%") (define %default-options ;; Alist of default option values. `((format . tarball) + (profile-name . "guix-profile") (system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) (graft? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (verbosity . 0) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -576,6 +610,18 @@ please email '~a'~%") (squashfs . ,squashfs-image) (docker . ,docker-image))) +(define (show-formats) + ;; Print the supported pack formats. + (display (G_ "The supported formats for 'guix pack' are:")) + (newline) + (display (G_ " + tarball Self-contained tarball, ready to run on another machine")) + (display (G_ " + squashfs Squashfs image suitable for Singularity")) + (display (G_ " + docker Tarball ready for 'docker load'")) + (newline)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -592,6 +638,10 @@ please email '~a'~%") (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '("list-formats") #f #f + (lambda args + (show-formats) + (exit 0))) (option '(#\R "relocatable") #f #f (lambda (opt name arg result) (alist-cons 'relocatable? #t result))) @@ -630,6 +680,13 @@ please email '~a'~%") (option '("localstatedir") #f #f (lambda (opt name arg result) (alist-cons 'localstatedir? #t result))) + (option '("profile-name") #t #f + (lambda (opt name arg result) + (match arg + ((or "guix-profile" "current-guix") + (alist-cons 'profile-name arg result)) + (_ + (leave (G_ "~a: unsupported profile name~%") arg))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -647,6 +704,8 @@ Create a bundle of PACKAGE.\n")) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " + --list-formats list the formats available")) + (display (G_ " -R, --relocatable produce relocatable executables")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) @@ -663,6 +722,9 @@ Create a bundle of PACKAGE.\n")) (display (G_ " --localstatedir include /var/guix in the resulting pack")) (display (G_ " + --profile-name=NAME + populate /var/guix/profiles/.../NAME")) + (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) (display (G_ " @@ -712,72 +774,76 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (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)) - (assoc-ref opts 'system) - #: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) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile - #:target - target - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir? - #:archiver - archiver))) - (mbegin %store-monad - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?) - (munless dry-run? - (built-derivations (list drv)) - (return (format #t "~a~%" - (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system))))))) + (with-status-report print-build-event + ;; 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)) + (assoc-ref opts 'system) + #: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~%") + pack-format)))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (profile-name (assoc-ref opts 'profile-name))) + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + manifest + #:relative-symlinks? relocatable? + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir? + #:profile-name + profile-name + #:archiver + archiver))) + (mbegin %store-monad + (show-what-to-build* (list drv) + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) + (munless dry-run? + (built-derivations (list drv)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system)))))))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b38a55d01c..5743816324 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -24,6 +24,7 @@ (define-module (guix scripts package) #:use-module (guix ui) + #:use-module (guix status) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix derivations) @@ -35,6 +36,7 @@ #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix describe) (current-profile-entries) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) @@ -66,50 +68,14 @@ (define (ensure-default-profile) "Ensure the default profile symlink and directory exist and are writable." - - (define (rtfm) - (format (current-error-port) - (G_ "Try \"info '(guix) Invoking guix package'\" for \ -more information.~%")) - (exit 1)) + (ensure-profile-directory) ;; Create ~/.guix-profile if it doesn't exist yet. (when (and %user-profile-directory %current-profile (not (false-if-exception (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory)) - - (let ((s (stat %profile-directory #f))) - ;; Attempt to create /…/profiles/per-user/$USER if needed. - (unless (and s (eq? 'directory (stat:type s))) - (catch 'system-error - (lambda () - (mkdir-p %profile-directory)) - (lambda args - ;; Often, we cannot create %PROFILE-DIRECTORY because its - ;; parent directory is root-owned and we're running - ;; unprivileged. - (format (current-error-port) - (G_ "error: while creating directory `~a': ~a~%") - %profile-directory - (strerror (system-error-errno args))) - (format (current-error-port) - (G_ "Please create the `~a' directory, with you as the owner.~%") - %profile-directory) - (rtfm)))) - - ;; Bail out if it's not owned by the user. - (unless (or (not s) (= (stat:uid s) (getuid))) - (format (current-error-port) - (G_ "error: directory `~a' is not owned by you~%") - %profile-directory) - (format (current-error-port) - (G_ "Please change the owner of `~a' to user ~s.~%") - %profile-directory (or (getenv "USER") - (getenv "LOGNAME") - (getuid))) - (rtfm)))) + (symlink %current-profile %user-profile-directory))) (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. @@ -198,7 +164,9 @@ do not treat collisions in MANIFEST as an error." count) count) (display-search-paths entries (list profile) - #:kind 'prefix)))))))) + #:kind 'prefix))) + + (warn-about-disk-space profile)))))) ;;; @@ -238,7 +206,7 @@ of relevance scores." (info (G_ "package '~a' has been superseded by '~a'~%") (manifest-entry-name old) (package-name new)) (manifest-transaction-install-entry - (package->manifest-entry new (manifest-entry-output old)) + (package->manifest-entry* new (manifest-entry-output old)) (manifest-transaction-remove-pattern (manifest-pattern (name (manifest-entry-name old)) @@ -261,7 +229,7 @@ of relevance scores." (case (version-compare candidate-version version) ((>) (manifest-transaction-install-entry - (package->manifest-entry pkg output) + (package->manifest-entry* pkg output) transaction)) ((<) transaction) @@ -274,7 +242,7 @@ of relevance scores." (null? (package-propagated-inputs pkg))) transaction (manifest-transaction-install-entry - (package->manifest-entry pkg output) + (package->manifest-entry* pkg output) transaction)))))))) (#f (warning (G_ "package '~a' no longer exists~%") name) @@ -328,7 +296,10 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." `((verbosity . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t))) + (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t))) (define (show-help) (display (G_ "Usage: guix package [OPTION]... @@ -570,6 +541,52 @@ upgrading, #f otherwise." (output "out") ;XXX: wild guess (item item)))) +(define (package-provenance package) + "Return the provenance of PACKAGE as an sexp for use as the 'provenance' +property of manifest entries, or #f if it could not be determined." + (define (entry-source entry) + (match (assq 'source + (manifest-entry-properties entry)) + (('source value) value) + (_ #f))) + + (match (and=> (package-location package) location-file) + (#f #f) + (file + (let ((file (if (string-prefix? "/" file) + file + (search-path %load-path file)))) + (and file + (string-prefix? (%store-prefix) file) + + ;; Always store information about the 'guix' channel and + ;; optionally about the specific channel FILE comes from. + (or (let ((main (and=> (find (lambda (entry) + (string=? "guix" + (manifest-entry-name entry))) + (current-profile-entries)) + entry-source)) + (extra (any (lambda (entry) + (let ((item (manifest-entry-item entry))) + (and (string-prefix? item file) + (entry-source entry)))) + (current-profile-entries)))) + (and main + `(,main + ,@(if extra (list extra) '())))))))))) + +(define (package->manifest-entry* package output) + "Like 'package->manifest-entry', but attach PACKAGE provenance meta-data to +the resulting manifest entry." + (define (provenance-properties package) + (match (package-provenance package) + (#f '()) + (sexp `((provenance ,@sexp))))) + + (package->manifest-entry package output + #:properties (provenance-properties package))) + + (define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', return an variant of TRANSACTION that accounts for the specified installations @@ -590,13 +607,13 @@ and upgrades." (('install . (? package? p)) ;; When given a package via `-e', install the first of its ;; outputs (XXX). - (package->manifest-entry p "out")) + (package->manifest-entry* p "out")) (('install . (? string? spec)) (if (store-path? spec) (store-item->manifest-entry spec) (let-values (((package output) (specification->package+output spec))) - (package->manifest-entry package output)))) + (package->manifest-entry* package output)))) (_ #f)) opts)) @@ -754,9 +771,13 @@ processed, #f otherwise." (('show requested-name) (let-values (((name version) (package-name->name+version requested-name))) - (leave-on-EPIPE - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-name name version))) + (match (find-packages-by-name name version) + (() + (leave (G_ "~a~@[@~a~]: package not found~%") name version)) + (packages + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + packages)))) #t)) (('search-paths kind) @@ -883,14 +904,18 @@ processed, #f otherwise." (arg-handler arg result) (leave (G_ "~A: extraneous argument~%") arg))) - (let ((opts (parse-command-line args %options (list %default-options #f) - #:argument-handler handle-argument))) - (with-error-handling - (or (process-query opts) - (parameterize ((%store (open-connection)) - (%graft? (assoc-ref opts 'graft?))) + (define opts + (parse-command-line args %options (list %default-options #f) + #:argument-handler handle-argument)) + (define verbose? + (assoc-ref opts 'verbose?)) + + (with-error-handling + (or (process-query opts) + (parameterize ((%store (open-connection)) + (%graft? (assoc-ref opts 'graft?))) + (with-status-report print-build-event/quiet (set-build-options-from-command-line (%store) opts) - (parameterize ((%guile-for-build (package-derivation (%store) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 18e2fc92f2..df787a9940 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +41,8 @@ (module-use! module (resolve-interface '(guix base32))) module)) -(define* (perform-download drv #:optional output) +(define* (perform-download drv #:optional output + #:key print-build-trace?) "Perform the download described by DRV, a fixed-output derivation, to OUTPUT. @@ -67,6 +68,7 @@ actual output is different from that when we're doing a 'bmCheck' or ;; We're invoked by the daemon, which gives us write access to OUTPUT. (when (url-fetch url output + #:print-build-trace? print-build-trace? #:mirrors (if mirrors (call-with-input-file mirrors read) '()) @@ -98,6 +100,11 @@ allows us to sidestep bootstrapping problems, such downloading the source code of GnuTLS over HTTPS, before we have built GnuTLS. See <http://bugs.gnu.org/22774>." + (define print-build-trace? + (match (getenv "_NIX_OPTIONS") + (#f #f) + (str (string-contains str "print-extended-build-trace=1")))) + ;; This program must be invoked by guix-daemon under an unprivileged UID to ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code ;; execution via the content-addressed mirror procedures. (That means we @@ -107,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See (((? derivation-path? drv) (? store-path? output)) (assert-low-privileges) (perform-download (read-derivation-from-file drv) - output)) + output + #:print-build-trace? print-build-trace?)) (((? derivation-path? drv)) ;backward compatibility (assert-low-privileges) - (perform-download (read-derivation-from-file drv))) + (perform-download (read-derivation-from-file drv) + #:print-build-trace? print-build-trace?)) (("--version") (show-version-and-exit)) (x diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm new file mode 100644 index 0000000000..6a2f603599 --- /dev/null +++ b/guix/scripts/processes.scm @@ -0,0 +1,223 @@ +;;; GNU Guix --- Functional package management for GNU +;;; 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 scripts processes) + #:use-module ((guix store) #:select (%store-prefix)) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-37) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 format) + #:export (process? + process-id + process-parent-id + process-command + processes + + daemon-session? + daemon-session-process + daemon-session-client + daemon-session-children + daemon-session-locks-held + daemon-sessions + + guix-processes)) + +;; Process as can be found in /proc on GNU/Linux. +(define-record-type <process> + (process id parent command) + process? + (id process-id) ;integer + (parent process-parent-id) ;integer | #f + (command process-command)) ;list of strings + +(define (write-process process port) + (format port "#<process ~a>" (process-id process))) + +(set-record-type-printer! <process> write-process) + +(define (read-status-ppid port) + "Read the PPID from PORT, an input port on a /proc/PID/status file. Return +#f for PID 1 and kernel pseudo-processes." + (let loop () + (match (read-line port) + ((? eof-object?) #f) + (line + (if (string-prefix? "PPid:" line) + (string->number (string-trim-both (string-drop line 5))) + (loop)))))) + +(define %not-nul + (char-set-complement (char-set #\nul))) + +(define (read-command-line port) + "Read the zero-split command line from PORT, a /proc/PID/cmdline file, and +return it as a list." + (string-tokenize (read-string port) %not-nul)) + +(define (processes) + "Return a list of process records representing the currently alive +processes." + ;; This assumes a Linux-compatible /proc file system. There exists one for + ;; GNU/Hurd. + (filter-map (lambda (pid) + ;; There's a TOCTTOU race here. If we get ENOENT, simply + ;; ignore PID. + (catch 'system-error + (lambda () + (define ppid + (call-with-input-file (string-append "/proc/" pid "/status") + read-status-ppid)) + (define command + (call-with-input-file (string-append "/proc/" pid "/cmdline") + read-command-line)) + (process (string->number pid) ppid command)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + (scandir "/proc" string->number))) + +(define (process-open-files process) + "Return the list of files currently open by PROCESS." + (let ((directory (string-append "/proc/" + (number->string (process-id process)) + "/fd"))) + (map (lambda (fd) + (readlink (string-append directory "/" fd))) + (or (scandir directory string->number) '())))) + +;; Daemon session. +(define-record-type <daemon-session> + (daemon-session process client children locks) + daemon-session? + (process daemon-session-process) ;<process> + (client daemon-session-client) ;<process> + (children daemon-session-children) ;list of <process> + (locks daemon-session-locks-held)) ;list of strings + +(define (daemon-sessions) + "Return two values: the list of <daemon-session> denoting the currently +active sessions, and the master 'guix-daemon' process." + (define (lock-file? file) + (and (string-prefix? (%store-prefix) file) + (string-suffix? ".lock" file))) + + (let* ((processes (processes)) + (daemons (filter (lambda (process) + (match (process-command process) + ((argv0 _ ...) + (string=? (basename argv0) "guix-daemon")) + (_ #f))) + processes)) + (children (filter (lambda (process) + (match (process-command process) + ((argv0 (= string->number argv1) _ ...) + (integer? argv1)) + (_ #f))) + daemons)) + (master (remove (lambda (process) + (memq process children)) + daemons))) + (define (lookup-process pid) + (find (lambda (process) + (and (process-id process) + (= pid (process-id process)))) + processes)) + + (define (lookup-children pid) + (filter (lambda (process) + (and (process-parent-id process) + (= pid (process-parent-id process)))) + processes)) + + (values (map (lambda (process) + (match (process-command process) + ((argv0 (= string->number client) _ ...) + (let ((files (process-open-files process))) + (daemon-session process + (lookup-process client) + (lookup-children (process-id process)) + (filter lock-file? files)))))) + children) + master))) + +(define (daemon-session->recutils session port) + "Display SESSION information in recutils format on PORT." + (format port "SessionPID: ~a~%" + (process-id (daemon-session-process session))) + (format port "ClientPID: ~a~%" + (process-id (daemon-session-client session))) + (format port "ClientCommand:~{ ~a~}~%" + (process-command (daemon-session-client session))) + (for-each (lambda (lock) + (format port "LockHeld: ~a~%" lock)) + (daemon-session-locks-held session)) + (for-each (lambda (process) + (format port "ChildProcess: ~a:~{ ~a~}~%" + (process-id process) + (process-command process))) + (daemon-session-children session))) + + +;;; +;;; Options. +;;; + +(define %options + (list (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix processes"))))) + +(define (show-help) + (display (G_ "Usage: guix processes +List the current Guix sessions and their processes.")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry point. +;;; + +(define (guix-processes . args) + (define options + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + cons + '())) + + (for-each (lambda (session) + (daemon-session->recutils session (current-output-port)) + (newline)) + (daemon-sessions))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index b5dfdab32f..c5326b33da 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -44,9 +44,9 @@ #:use-module (guix base64) #:use-module (guix config) #:use-module (guix derivations) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix pki) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 433502b5de..dc83729911 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -20,6 +20,7 @@ (define-module (guix scripts pull) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix status) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix config) @@ -30,64 +31,26 @@ #:use-module (guix grafts) #:use-module (guix memoization) #:use-module (guix monads) + #:use-module (guix channels) #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) - #:autoload (guix self) (whole-package) + #:use-module (guix git) + #:use-module (git) #:use-module (gnu packages) - #:autoload (gnu packages ssh) (guile-ssh) - #:autoload (gnu packages tls) (gnutls) #:use-module ((guix scripts package) #:select (build-and-use-profile)) - #:use-module ((guix build utils) - #:select (with-directory-excursion delete-file-recursively)) - #:use-module ((guix build download) - #:select (%x509-certificate-directory)) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 vlist) - #:export (guix-pull)) - -(module-autoload! (resolve-module '(guix scripts pull)) - '(git) '(git-error? set-tls-certificate-locations!) - '(guix git) '(latest-repository-commit)) - -(define (ensure-guile-git!) - ;; Previously Guile-Git was not a prerequisite. Thus, someone running 'guix - ;; pull' on an old installation may be lacking Guile-Git. To address this, - ;; we autoload things that depend on Guile-Git and check in the entry point - ;; whether Guile-Git is available. - ;; - ;; TODO: Remove this hack when Guile-Git is widespread or enforced. - - (unless (false-if-exception (resolve-interface '(git))) - (leave (G_ "Guile-Git is missing but it is now required by 'guix pull'. -Install it by running: - - guix package -i ~a - export GUILE_LOAD_PATH=$HOME/.guix-profile/share/guile/site/~a:$GUILE_LOAD_PATH - export GUILE_LOAD_COMPILED_PATH=$HOME/.guix-profile/lib/guile/~a/site-ccache:$GUILE_LOAD_COMPILED_PATH -\n") - (match (effective-version) - ("2.0" "guile2.0-git") - (_ "guile-git")) - (effective-version) - (effective-version))) - - ;; XXX: For unclear reasons this is needed for - ;; 'set-tls-certificate-locations!'. - (module-use! (resolve-module '(guix scripts pull)) - (resolve-interface '(git)))) - -(define %repository-url - (or (getenv "GUIX_PULL_URL") "https://git.savannah.gnu.org/git/guix.git")) + #:export (display-profile-content + guix-pull)) ;;; @@ -96,11 +59,12 @@ Install it by running: (define %default-options ;; Alist of default option values. - `((repository-url . ,%repository-url) - (ref . (branch . "origin/master")) - (system . ,(%current-system)) + `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0))) @@ -110,6 +74,8 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " --verbose produce verbose output")) (display (G_ " + -C, --channels=FILE deploy the channels defined in FILE")) + (display (G_ " --url=URL download from the Git repository at URL")) (display (G_ " --commit=COMMIT download the specified COMMIT")) @@ -119,6 +85,10 @@ Download and deploy the latest version of Guix.\n")) -l, --list-generations[=PATTERN] list generations matching PATTERN")) (display (G_ " + -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) + (display (G_ " + -n, --dry-run show what would be pulled and built")) + (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) (show-build-options-help) @@ -134,6 +104,9 @@ Download and deploy the latest version of Guix.\n")) (cons* (option '("verbose") #f #f (lambda (opt name arg result) (alist-cons 'verbose? #t result))) + (option '(#\C "channels") #t #f + (lambda (opt name arg result) + (alist-cons 'channel-file arg result))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) @@ -149,6 +122,10 @@ Download and deploy the latest version of Guix.\n")) (lambda (opt name arg result) (alist-cons 'ref `(branch . ,(string-append "origin/" arg)) result))) + (option '(#\p "profile") #t #f + (lambda (opt name arg result) + (alist-cons 'profile (canonicalize-profile arg) + result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -171,70 +148,6 @@ Download and deploy the latest version of Guix.\n")) (define indirect-root-added (store-lift add-indirect-root)) -(define %self-build-file - ;; The file containing code to build Guix. This serves the same purpose as - ;; a makefile, and, similarly, is intended to always keep this name. - "build-aux/build-self.scm") - -(define %pull-version - ;; This is the version of the 'guix pull' protocol. It specifies what's - ;; expected from %SELF-BUILD-FILE. The initial version ("0") was when we'd - ;; place a set of compiled Guile modules in ~/.config/guix/latest. - 1) - -(define* (build-from-source source - #:key verbose? commit) - "Return a derivation to build Guix from SOURCE, using the self-build script -contained therein. Use COMMIT as the version string." - ;; Running the self-build script makes it easier to update the build - ;; procedure: the self-build script of the Guix-to-be-installed contains the - ;; right dependencies, build procedure, etc., which the Guix-in-use may not - ;; be know. - (let* ((script (string-append source "/" %self-build-file)) - (build (primitive-load script))) - ;; BUILD must be a monadic procedure of at least one argument: the source - ;; tree. - ;; - ;; Note: BUILD can return #f if it does not support %PULL-VERSION. In the - ;; future we'll fall back to a previous version of the protocol when that - ;; happens. - (build source #:verbose? verbose? #:version commit - #:pull-version %pull-version))) - -(define (whole-package-for-legacy name modules) - "Return a full-blown Guix package for MODULES, a derivation that builds Guix -modules in the old ~/.config/guix/latest style." - (whole-package name modules - - ;; In the "old style", %SELF-BUILD-FILE would simply return a - ;; derivation that builds modules. We have to infer what the - ;; dependencies of these modules were. - (list guile-json guile-git guile-bytestructures - guile-ssh gnutls))) - -(define* (derivation->manifest-entry drv - #:key url branch commit) - "Return a manifest entry for DRV, which represents Guix at COMMIT. Record -URL, BRANCH, and COMMIT as a property in the manifest entry." - (mbegin %store-monad - (what-to-build (list drv)) - (built-derivations (list drv)) - (let ((out (derivation->output-path drv))) - (return (manifest-entry - (name "guix") - (version (string-take commit 7)) - (item (if (file-exists? (string-append out "/bin/guix")) - drv - (whole-package-for-legacy (string-append name "-" - version) - drv))) - (properties - `((source (repository - (version 0) - (url ,url) - (branch ,branch) - (commit ,commit)))))))))) - (define (display-profile-news profile) "Display what's up in PROFILE--new packages, and all that." (match (memv (generation-number profile) @@ -252,25 +165,19 @@ URL, BRANCH, and COMMIT as a property in the manifest entry." #:heading (G_ "New in this revision:\n")))) (_ #t))) -(define* (build-and-install source config-dir - #:key verbose? url branch commit) - "Build the tool from SOURCE, and install it in CONFIG-DIR." +(define* (build-and-install instances profile + #:key verbose? dry-run?) + "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is +true, display what would be built without actually building it." (define update-profile (store-lift build-and-use-profile)) - (define profile - (string-append config-dir "/current")) - - (mlet* %store-monad ((drv (build-from-source source - #:commit commit - #:verbose? verbose?)) - (entry (derivation->manifest-entry drv - #:url url - #:branch branch - #:commit commit))) + (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad - (update-profile profile (manifest (list entry))) - (return (display-profile-news profile))))) + (update-profile profile manifest + #:dry-run? dry-run?) + (munless dry-run? + (return (display-profile-news profile)))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -278,17 +185,34 @@ URL, BRANCH, and COMMIT as a property in the manifest entry." (certs (string-append (derivation->output-path drv) "/etc/ssl/certs"))) (build-derivations store (list drv)) - - ;; In the past Guile-Git would not provide this procedure. - (if (module-defined? (resolve-interface '(git)) - 'set-tls-certificate-locations!) - (set-tls-certificate-locations! certs) - (begin - ;; In this case we end up using whichever certificates OpenSSL - ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs. - (warning (G_ "cannot enforce use of the Let's Encrypt \ -certificates~%")) - (warning (G_ "please upgrade Guile-Git~%")))))) + (set-tls-certificate-locations! certs))) + +(define (honor-x509-certificates store) + "Use the right X.509 certificates for Git checkouts over HTTPS." + ;; On distros such as CentOS 7, /etc/ssl/certs contains only a couple of + ;; files (instead of all the certificates) among which "ca-bundle.crt". On + ;; other distros /etc/ssl/certs usually contains the whole set of + ;; certificates along with "ca-certificates.crt". Try to choose the right + ;; one. + (let ((file (letrec-syntax ((choose + (syntax-rules () + ((_ file rest ...) + (let ((f file)) + (if (and f (file-exists? f)) + f + (choose rest ...)))) + ((_) + #f)))) + (choose (getenv "SSL_CERT_FILE") + "/etc/ssl/certs/ca-certificates.crt" + "/etc/ssl/certs/ca-bundle.crt"))) + (directory (or (getenv "SSL_CERT_DIR") "/etc/ssl/certs"))) + (if (or file + (and=> (stat directory #f) + (lambda (st) + (> (stat:nlink st) 2)))) + (set-tls-certificate-locations! directory file) + (honor-lets-encrypt-certificates! store)))) (define (report-git-error error) "Report the given Guile-Git error." @@ -309,6 +233,60 @@ certificates~%")) ;;; +;;; Profile. +;;; + +(define %current-profile + ;; The "real" profile under /var/guix. + (string-append %profile-directory "/current-guix")) + +(define %user-profile-directory + ;; The user-friendly name of %CURRENT-PROFILE. + (string-append (config-directory #:ensure? #f) "/current")) + +(define (migrate-generations profile directory) + "Migrate the generations of PROFILE to DIRECTORY." + (format (current-error-port) + (G_ "Migrating profile generations to '~a'...~%") + %profile-directory) + (let ((current (generation-number profile))) + (for-each (lambda (generation) + (let ((source (generation-file-name profile generation)) + (target (string-append directory "/current-guix-" + (number->string generation) + "-link"))) + ;; Note: Don't use 'rename-file' as SOURCE and TARGET might + ;; live on different file systems. + (symlink (readlink source) target) + (delete-file source))) + (profile-generations profile)) + (symlink (string-append "current-guix-" + (number->string current) "-link") + (string-append directory "/current-guix")))) + +(define (ensure-default-profile) + (ensure-profile-directory) + + ;; In 0.15.0+ we'd create ~/.config/guix/current-[0-9]*-link symlinks. Move + ;; them to %PROFILE-DIRECTORY. + (unless (string=? %profile-directory + (dirname (canonicalize-profile %user-profile-directory))) + (migrate-generations %user-profile-directory %profile-directory)) + + ;; Make sure ~/.config/guix/current points to /var/guix/profiles/…. + (let ((link %user-profile-directory)) + (unless (equal? (false-if-exception (readlink link)) + %current-profile) + (catch 'system-error + (lambda () + (false-if-exception (delete-file link)) + (symlink %current-profile link)) + (lambda args + (leave (G_ "while creating symlink '~a': ~a~%") + link (strerror (system-error-errno args)))))))) + + +;;; ;;; Queries. ;;; @@ -335,7 +313,9 @@ way and displaying details about the channel's source code." ;; Show most recently installed packages last. (reverse (manifest-entries - (profile-manifest (generation-file-name profile number)))))) + (profile-manifest (if (zero? number) + profile + (generation-file-name profile number))))))) (define (indented-string str indent) "Return STR with each newline preceded by IDENT spaces." @@ -421,11 +401,8 @@ and ALIST2 differ, display HEADING upfront." (display-new/upgraded-packages (package-alist gen1) (package-alist gen2))) -(define (process-query opts) - "Process any query specified by OPTS." - (define profile - (string-append (config-directory) "/current")) - +(define (process-query opts profile) + "Process any query on PROFILE specified by OPTS." (match (assoc-ref opts 'query) (('list-generations pattern) (define (list-generations profile numbers) @@ -455,62 +432,111 @@ and ALIST2 differ, display HEADING upfront." ((numbers ...) (list-generations profile numbers))))))))) +(define (channel-list opts) + "Return the list of channels to use. If OPTS specify a channel file, +channels are read from there; otherwise, if ~/.config/guix/channels.scm +exists, read it; otherwise %DEFAULT-CHANNELS is used. Apply channel +transformations specified in OPTS (resulting from '--url', '--commit', or +'--branch'), if any." + (define file + (assoc-ref opts 'channel-file)) + + (define default-file + (string-append (config-directory) "/channels.scm")) + + (define (load-channels file) + (let ((result (load* file (make-user-module '((guix channels)))))) + (if (and (list? result) (every channel? result)) + result + (leave (G_ "'~a' did not return a list of channels~%") file)))) + + (define channels + (cond (file + (load-channels file)) + ((file-exists? default-file) + (load-channels default-file)) + (else + %default-channels))) + + (define (environment-variable) + (match (getenv "GUIX_PULL_URL") + (#f #f) + (url + (warning (G_ "The 'GUIX_PULL_URL' environment variable is deprecated. +Use '~/.config/guix/channels.scm' instead.")) + url))) + + (let ((ref (assoc-ref opts 'ref)) + (url (or (assoc-ref opts 'repository-url) + (environment-variable)))) + (if (or ref url) + (match channels + ((one) + ;; When there's only one channel, apply '--url', '--commit', and + ;; '--branch' to this specific channel. + (let ((url (or url (channel-url one)))) + (list (match ref + (('commit . commit) + (channel (inherit one) + (url url) (commit commit) (branch #f))) + (('branch . branch) + (channel (inherit one) + (url url) (commit #f) (branch branch))) + (#f + (channel (inherit one) (url url))))))) + (_ + ;; Otherwise bail out. + (leave + (G_ "'--url', '--commit', and '--branch' are not applicable~%")))) + channels))) + (define (guix-pull . args) - (define (use-le-certs? url) - (string-prefix? "https://git.savannah.gnu.org/" url)) - (with-error-handling (with-git-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) - (url (assoc-ref opts 'repository-url)) - (ref (assoc-ref opts 'ref)) - (cache (string-append (cache-directory) "/pull"))) - (ensure-guile-git!) - + (let* ((opts (parse-command-line args %options + (list %default-options))) + (cache (string-append (cache-directory) "/pull")) + (channels (channel-list opts)) + (profile (or (assoc-ref opts 'profile) %current-profile))) + (ensure-default-profile) (cond ((assoc-ref opts 'query) - (process-query opts)) - ((assoc-ref opts 'dry-run?) - #t) ;XXX: not very useful + (process-query opts profile)) (else (with-store store - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line store opts) - - ;; For reproducibility, always refer to the LE certificates - ;; when we know we're talking to Savannah. - (when (use-le-certs? url) - (honor-lets-encrypt-certificates! store)) - - (format (current-error-port) - (G_ "Updating from Git repository at '~a'...~%") - url) - - (let-values (((checkout commit) - (latest-repository-commit store url - #:ref ref - #:cache-directory - cache))) - - (format (current-error-port) - (G_ "Building from Git commit ~a...~%") - commit) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - (build-and-install checkout (config-directory) - #:url url - #:branch (match ref - (('branch . branch) - branch) - (_ #f)) - #:commit commit - #:verbose? - (assoc-ref opts 'verbose?))))))))))))) + (with-status-report print-build-event + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%repository-cache-directory cache)) + (set-build-options-from-command-line store opts) + (honor-x509-certificates store) + + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + (build-and-install instances profile + #:dry-run? + (assoc-ref opts 'dry-run?) + #:verbose? + (assoc-ref opts 'verbose?)))))))))))))) ;;; pull.scm ends here diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index a8fe993e33..58fc64db1f 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -23,7 +23,7 @@ (define-module (guix scripts refresh) #:use-module (guix ui) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) @@ -89,6 +89,9 @@ (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '("keyring") #t #f + (lambda (opt name arg result) + (alist-cons 'keyring arg result))) (option '("key-server") #t #f (lambda (opt name arg result) (alist-cons 'key-server arg result))) @@ -139,6 +142,8 @@ specified with `--select'.\n")) be rebuilt as a result of upgrading PACKAGE...")) (newline) (display (G_ " + --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) + (display (G_ " --key-server=HOST use HOST as the OpenPGP key server")) (display (G_ " --gpg=COMMAND use COMMAND as the GnuPG 2.x command")) @@ -437,7 +442,11 @@ update would trigger a complete rebuild." (%openpgp-key-server))) (%gpg-command (or (assoc-ref opts 'gpg-command) - (%gpg-command)))) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) (for-each (cut update-package store <> updaters #:key-download key-download diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index b157833a49..02169e8004 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -188,7 +188,15 @@ call THUNK." (save-module-excursion (lambda () (set-current-module user-module) - (start-repl)))) + (and=> (getenv "HOME") + (lambda (home) + (let ((guile (string-append home "/.guile"))) + (when (file-exists? guile) + (load guile))))) + ;; Do not exit repl on SIGINT. + ((@@ (ice-9 top-repl) call-with-sigint) + (lambda () + (start-repl)))))) ((machine) (machine-repl)) (else diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 7634bb37f6..eb82224016 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -26,11 +26,11 @@ #:use-module (guix config) #:use-module (guix records) #:use-module ((guix serialization) #:select (restore-file)) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix cache) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) @@ -837,8 +837,17 @@ REPORTER, which should be a <progress-reporter> object." (make-custom-binary-input-port "progress-port-proc" read! #f #f (lambda () - (close-connection port) - (stop))))))) + ;; XXX: Kludge! When used through + ;; 'decompressed-port', this port ends + ;; up being closed twice: once in a + ;; child process early on, and at the + ;; end in the parent process. Ignore + ;; the early close so we don't output + ;; a spurious "download-succeeded" + ;; trace. + (unless (zero? total) + (stop)) + (close-port port))))))) (define-syntax with-networking (syntax-rules () @@ -930,7 +939,7 @@ authorized substitutes." (error "unknown `--query' command" wtf)))) (define* (process-substitution store-item destination - #:key cache-urls acl) + #:key cache-urls acl print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL." (let* ((narinfo (lookup-narinfo cache-urls store-item @@ -943,8 +952,10 @@ DESTINATION as a nar file. Verify the substitute against ACL." ;; Tell the daemon what the expected hash of the Nar itself is. (format #t "~a~%" (narinfo-hash narinfo)) - (format (current-error-port) - (G_ "Downloading ~a...~%") (uri->string uri)) + (unless print-build-trace? + (format (current-error-port) + (G_ "Downloading ~a...~%") (uri->string uri))) + (let*-values (((raw download-size) ;; Note that Hydra currently generates Nars on the fly ;; and doesn't specify a Content-Length, so @@ -955,10 +966,15 @@ DESTINATION as a nar file. Verify the substitute against ACL." (dl-size (or download-size (and (equal? comp "none") (narinfo-size narinfo)))) - (reporter (progress-reporter/file - (uri->string uri) dl-size - (current-error-port) - #:abbreviation nar-uri-abbreviation))) + (reporter (if print-build-trace? + (progress-reporter/trace + destination + (uri->string uri) dl-size + (current-error-port)) + (progress-reporter/file + (uri->string uri) dl-size + (current-error-port) + #:abbreviation nar-uri-abbreviation)))) (progress-report-port reporter raw))) ((input pids) ;; NOTE: This 'progress' port of current process will be @@ -1058,6 +1074,13 @@ default value." (define (guix-substitute . args) "Implement the build daemon's substituter protocol." + (define print-build-trace? + (match (or (find-daemon-option "untrusted-print-extended-build-trace") + (find-daemon-option "print-extended-build-trace")) + (#f #f) + ((= string->number number) (> number 0)) + (_ #f))) + (mkdir-p %narinfo-cache-directory) (maybe-remove-expired-cache-entries %narinfo-cache-directory cached-narinfo-files @@ -1087,7 +1110,10 @@ default value." (#f #f) (locale (false-if-exception (setlocale LC_ALL locale)))) - (set-thread-name "guix substitute") + (catch 'system-error + (lambda () + (set-thread-name "guix substitute")) + (const #t)) ;GNU/Hurd lacks 'prctl' (with-networking (with-error-handling ; for signature errors @@ -1108,7 +1134,8 @@ default value." (parameterize ((current-terminal-columns (client-terminal-columns))) (process-substitution store-path destination #:cache-urls (substitute-urls) - #:acl (current-acl)))) + #:acl (current-acl) + #:print-build-trace? print-build-trace?))) ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) (("--help") diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 69bd05b516..d92ec7d5a5 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -23,6 +23,7 @@ (define-module (guix scripts system) #:use-module (guix config) #:use-module (guix ui) + #:use-module (guix status) #:use-module (guix store) #:autoload (guix store database) (register-path) #:use-module (guix grafts) @@ -174,12 +175,16 @@ TARGET, and register them." (return *unspecified*))) -(define* (install-bootloader installer-drv +(define* (install-bootloader installer #:key bootcfg bootcfg-file target) - "Call INSTALLER-DRV with error handling, in %STORE-MONAD." - (with-monad %store-monad + "Run INSTALLER, a bootloader installation script, with error handling, in +%STORE-MONAD." + (mlet %store-monad ((installer-drv (if installer + (lower-object installer) + (return #f))) + (bootcfg (lower-object bootcfg))) (let* ((gc-root (string-append target %gc-roots-directory "/bootcfg")) (temp-gc-root (string-append gc-root ".new")) @@ -234,26 +239,33 @@ When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG." the ownership of '~a' may be incorrect!~%") target)) + ;; If a previous installation was attempted, make sure we start anew; in + ;; particular, we don't want to keep a store database that might not + ;; correspond to what we're actually putting in the store. + (let ((state (string-append target "/var/guix"))) + (when (file-exists? state) + (delete-file-recursively state))) + (chmod target #o755) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) (populate (lift2 populate-root-file-system %store-monad))) - (mbegin %store-monad - ;; Copy the closure of BOOTCFG, which includes OS-DIR, - ;; eventual background image and so on. - (maybe-copy - (derivation->output-path bootcfg)) + (mlet %store-monad ((bootcfg (lower-object bootcfg))) + (mbegin %store-monad + ;; Copy the closure of BOOTCFG, which includes OS-DIR, + ;; eventual background image and so on. + (maybe-copy (derivation->output-path bootcfg)) - ;; Create a bunch of additional files. - (format log-port "populating '~a'...~%" target) - (populate os-dir target) + ;; Create a bunch of additional files. + (format log-port "populating '~a'...~%" target) + (populate os-dir target) - (mwhen install-bootloader? - (install-bootloader bootloader-installer - #:bootcfg bootcfg - #:bootcfg-file bootcfg-file - #:target target))))) + (mwhen install-bootloader? + (install-bootloader bootloader-installer + #:bootcfg bootcfg + #:bootcfg-file bootcfg-file + #:target target)))))) ;;; @@ -310,9 +322,9 @@ names of services to load (upgrade), and the list of names of services to unload." (match (current-services) ((services ...) - (let-values (((to-unload to-load) + (let-values (((to-unload to-restart) (shepherd-service-upgrade services new-services))) - (mproc to-load + (mproc to-restart (map (compose first live-service-provision) to-unload)))) (#f @@ -335,25 +347,32 @@ bring the system down." ;; Arrange to simply emit a warning if the service upgrade fails. (with-shepherd-error-handling (call-with-service-upgrade-info new-services - (lambda (to-load to-unload) + (lambda (to-restart to-unload) (for-each (lambda (unload) (info (G_ "unloading service '~a'...~%") unload) (unload-service unload)) to-unload) (with-monad %store-monad - (munless (null? to-load) - (let ((to-load-names (map shepherd-service-canonical-name to-load)) - (to-start (filter shepherd-service-auto-start? to-load))) - (info (G_ "loading new services:~{ ~a~}...~%") to-load-names) + (munless (null? new-services) + (let ((new-service-names (map shepherd-service-canonical-name new-services)) + (to-restart-names (map shepherd-service-canonical-name to-restart)) + (to-start (filter shepherd-service-auto-start? new-services))) + (info (G_ "loading new services:~{ ~a~}...~%") new-service-names) + (unless (null? to-restart-names) + ;; Listing TO-RESTART-NAMES in the message below wouldn't help + ;; because many essential services cannot be meaningfully + ;; restarted. See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>. + (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop, +upgrade, and restart each service that was not automatically restarted.\n"))) (mlet %store-monad ((files (mapm %store-monad (compose lower-object shepherd-service-file) - to-load))) + new-services))) ;; Here we assume that FILES are exactly those that were computed ;; as part of the derivation that built OS, which is normally the ;; case. - (load-services (map derivation->output-path files)) + (load-services/safe (map derivation->output-path files)) (for-each start-service (map shepherd-service-canonical-name to-start)) @@ -775,19 +794,18 @@ checking this by themselves in their 'check' procedure." (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (G_ "Failing to do that may downgrade your system!~%")))) -(define (bootloader-installer-derivation installer - bootloader device target) +(define (bootloader-installer-script installer + bootloader device target) "Return a file calling INSTALLER gexp with given BOOTLOADER, DEVICE and TARGET arguments." - (with-monad %store-monad - (gexp->file "bootloader-installer" - (with-imported-modules '((gnu build bootloader) - (guix build utils)) - #~(begin - (use-modules (gnu build bootloader) - (guix build utils) - (ice-9 binary-ports)) - (#$installer #$bootloader #$device #$target)))))) + (scheme-file "bootloader-installer" + (with-imported-modules '((gnu build bootloader) + (guix build utils)) + #~(begin + (use-modules (gnu build bootloader) + (guix build utils) + (ice-9 binary-ports)) + (#$installer #$bootloader #$device #$target))))) (define* (perform-action action os #:key skip-safety-checks? @@ -815,6 +833,25 @@ static checks." (define println (cut format #t "~a~%" <>)) + (define menu-entries + (if (eq? 'init action) + '() + (map boot-parameters->menu-entry (profile-boot-parameters)))) + + (define bootloader + (bootloader-configuration-bootloader (operating-system-bootloader os))) + + (define bootcfg + (and (not (eq? 'container action)) + (operating-system-bootcfg os menu-entries))) + + (define bootloader-script + (let ((installer (bootloader-installer bootloader)) + (target (or target "/"))) + (bootloader-installer-script installer + (bootloader-package bootloader) + bootloader-target target))) + (when (eq? action 'reconfigure) (maybe-suggest-running-guix-pull)) @@ -834,39 +871,16 @@ static checks." #:image-size image-size #:full-boot? full-boot? #:mappings mappings)) - (bootloader -> (bootloader-configuration-bootloader - (operating-system-bootloader os))) - (bootloader-package - (let ((package (bootloader-package bootloader))) - (if package - (package->derivation package) - (return #f)))) - (bootcfg (if (eq? 'container action) - (return #f) - (operating-system-bootcfg - os - (if (eq? 'init action) - '() - (map boot-parameters->menu-entry - (profile-boot-parameters)))))) - (bootcfg-file -> (bootloader-configuration-file bootloader)) - (bootloader-installer - (let ((installer (bootloader-installer bootloader)) - (target (or target "/"))) - (bootloader-installer-derivation installer - bootloader-package - bootloader-target target))) ;; For 'init' and 'reconfigure', always build BOOTCFG, even if ;; --no-bootloader is passed, because we then use it as a GC root. ;; See <http://bugs.gnu.org/21068>. - (drvs -> (if (memq action '(init reconfigure)) - (if (and install-bootloader? bootloader-package) - (list sys bootcfg - bootloader-package - bootloader-installer) - (list sys bootcfg)) - (list sys))) + (drvs (mapm %store-monad lower-object + (if (memq action '(init reconfigure)) + (if install-bootloader? + (list sys bootcfg bootloader-script) + (list sys bootcfg)) + (list sys)))) (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) @@ -875,7 +889,7 @@ static checks." (if (or dry-run? derivations-only?) (return #f) - (begin + (let ((bootcfg-file (bootloader-configuration-file bootloader))) (for-each (compose println derivation->output-path) drvs) @@ -884,7 +898,7 @@ static checks." (mbegin %store-monad (switch-to-system os) (mwhen install-bootloader? - (install-bootloader bootloader-installer + (install-bootloader bootloader-script #:bootcfg bootcfg #:bootcfg-file bootcfg-file #:target "/")))) @@ -896,7 +910,7 @@ static checks." #:install-bootloader? install-bootloader? #:bootcfg bootcfg #:bootcfg-file bootcfg-file - #:bootloader-installer bootloader-installer)) + #:bootloader-installer bootloader-script)) (else ;; All we had to do was to build SYS and maybe register an ;; indirect GC root. @@ -1072,6 +1086,9 @@ Some ACTIONS support additional ARGS.\n")) `((system . ,(%current-system)) (substitutes? . #t) (build-hook? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) (graft? . #t) (verbosity . 0) (file-system-type . "ext4") @@ -1150,7 +1167,8 @@ resulting from command-line parsing." #:target target #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) - #:system system)))) + #:system system)) + (warn-about-disk-space))) (define (resolve-subcommand name) (let ((module (resolve-interface @@ -1246,9 +1264,11 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (current-terminal-columns (terminal-columns))) - (process-command command args opts))))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (with-status-report (if (memq command '(init reconfigure)) + print-build-event/quiet + print-build-event) + (process-command command args opts)))))) ;;; Local Variables: ;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) diff --git a/guix/self.scm b/guix/self.scm index 5ad644b1df..8476c422ec 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -83,8 +83,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) + ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) ("gnutls" (ref '(gnu packages tls) 'gnutls)) - ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) @@ -206,28 +206,22 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (local-file file #:recursive? #t))) (find-files (string-append directory "/" sub-directory) pred))) -(define (scheme-modules* directory sub-directory) - "Return the list of module names found under SUB-DIRECTORY in DIRECTORY." - (let ((prefix (string-length directory))) - (map (lambda (file) - (file-name->module-name (string-drop file prefix))) - (scheme-files (string-append directory "/" sub-directory))))) - -(define* (sub-directory item sub-directory) - "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like -object." +(define* (file-append* item file #:key (recursive? #t)) + "Return FILE within ITEM, which may be a file name or a file-like object. +When ITEM is a plain file name (a string), simply return a 'local-file' +record with the new file name." (match item ((? string?) ;; This is the optimal case: we return a new "source". Thus, a ;; derivation that depends on this sub-directory does not depend on ITEM ;; itself. - (local-file (string-append item "/" sub-directory) - #:recursive? #t)) + (local-file (string-append item "/" file) + #:recursive? recursive?)) ;; TODO: Add 'local-file?' case. (_ ;; In this case, anything that refers to the result also depends on ITEM, ;; which isn't great. - (file-append item "/" sub-directory)))) + (file-append item "/" file)))) (define* (locale-data source domain #:optional (directory domain)) @@ -245,7 +239,7 @@ DOMAIN, a gettext domain." (ice-9 match) (ice-9 ftw)) (define po-directory - #+(sub-directory source (string-append "po/" directory))) + #+(file-append* source (string-append "po/" directory))) (define (compile language) (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" @@ -279,11 +273,15 @@ DOMAIN, a gettext domain." (module-ref (resolve-interface '(gnu packages graphviz)) 'graphviz)) + (define glibc-utf8-locales + (module-ref (resolve-interface '(gnu packages base)) + 'glibc-utf8-locales)) + (define documentation - (sub-directory source "doc")) + (file-append* source "doc")) (define examples - (sub-directory source "gnu/system/examples")) + (file-append* source "gnu/system/examples")) (define build (with-imported-modules '((guix build utils)) @@ -297,7 +295,7 @@ DOMAIN, a gettext domain." ;; doesn't change at each commit? (call-with-output-file "version.texi" (lambda (port) - (let ((version "0.0-git)")) + (let ((version "0.0-git")) (format port " @set UPDATED 1 January 1970 @set UPDATED-MONTH January 1970 @@ -342,6 +340,10 @@ DOMAIN, a gettext domain." (delete-file-recursively "images") (symlink (string-append #$output "/images") "images") + ;; Provide UTF-8 locales needed by the 'xspara.c' code in makeinfo. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (for-each (lambda (texi) (unless (string=? "guix.texi" texi) ;; Create 'version-LL.texi'. @@ -367,22 +369,26 @@ DOMAIN, a gettext domain." guile (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." + (define source-directories + (map (lambda (package) + (file-append package "/share/guile/site/" + guile-version)) + dependencies)) + + (define object-directories + (map (lambda (package) + (file-append package "/lib/guile/" + guile-version "/site-ccache")) + dependencies)) + (program-file "guix-command" #~(begin (set! %load-path - (append '#$(map (lambda (package) - (file-append package - "/share/guile/site/" - guile-version)) - dependencies) + (append (filter file-exists? '#$source-directories) %load-path)) (set! %load-compiled-path - (append '#$(map (lambda (package) - (file-append package "/lib/guile/" - guile-version - "/site-ccache")) - dependencies) + (append (filter file-exists? '#$object-directories) %load-compiled-path)) (set! %load-path (cons #$modules %load-path)) @@ -407,11 +413,29 @@ load path." (apply guix-main (command-line)))) #:guile guile)) +(define (miscellaneous-files source) + "Return data files taken from SOURCE." + (file-mapping "guix-misc" + `(("etc/bash_completion.d/guix" + ,(file-append* source "/etc/completion/bash/guix")) + ("etc/bash_completion.d/guix-daemon" + ,(file-append* source "/etc/completion/bash/guix-daemon")) + ("share/zsh/site-functions/_guix" + ,(file-append* source "/etc/completion/zsh/_guix")) + ("share/fish/vendor_completions.d/guix.fish" + ,(file-append* source "/etc/completion/fish/guix.fish")) + ("share/guix/hydra.gnu.org.pub" + ,(file-append* source + "/etc/substitutes/hydra.gnu.org.pub")) + ("share/guix/berlin.guixsd.org.pub" + ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub"))))) + (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) compiled-modules - info daemon guile + info daemon miscellany + guile (command (guix-command modules #:dependencies dependencies #:guile guile @@ -425,6 +449,7 @@ assumed to be part of MODULES." (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")) (symlink #$command (string-append #$output "/bin/guix")) @@ -444,6 +469,10 @@ assumed to be part of MODULES." (string-append #$output "/share/info")))) + (when #$miscellany + (copy-recursively #$miscellany #$output + #:log (%make-void-port "w"))) + ;; Object files. (when #$compiled-modules (let ((modules (string-append #$output "/lib/guile/" @@ -457,7 +486,6 @@ assumed to be part of MODULES." (name (string-append "guix-" version)) (guile-version (effective-version)) (guile-for-build (guile-for-build guile-version)) - (libgcrypt (specification->package "libgcrypt")) (zlib (specification->package "zlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) @@ -484,6 +512,10 @@ assumed to be part of MODULES." "guile-sqlite3" "guile2.0-sqlite3")) + (define guile-gcrypt + (package-for-guile guile-version + "guile-gcrypt")) + (define gnutls (package-for-guile guile-version "gnutls" "guile2.0-gnutls")) @@ -492,7 +524,7 @@ assumed to be part of MODULES." (match (append-map (lambda (package) (cons (list "x" package) (package-transitive-propagated-inputs package))) - (list gnutls guile-git guile-json + (list guile-gcrypt gnutls guile-git guile-json guile-ssh guile-sqlite3)) (((labels packages _ ...) ...) packages))) @@ -516,10 +548,7 @@ assumed to be part of MODULES." ;; rebuilt when the version changes, which in turn means we ;; can have substitutes for it. #:extra-modules - `(((guix config) - => ,(make-config.scm #:libgcrypt - (specification->package - "libgcrypt")))) + `(((guix config) => ,(make-config.scm))) ;; (guix man-db) is needed at build-time by (guix profiles) ;; but we don't need to compile it; not compiling it allows @@ -529,6 +558,7 @@ assumed to be part of MODULES." ("guix/store/schema.sql" ,(local-file "../guix/store/schema.sql"))) + #:extensions (list guile-gcrypt) #:guile-for-build guile-for-build)) (define *extra-modules* @@ -603,8 +633,7 @@ assumed to be part of MODULES." '() #:extra-modules `(((guix config) - => ,(make-config.scm #:libgcrypt libgcrypt - #:zlib zlib + => ,(make-config.scm #:zlib zlib #:gzip gzip #:bzip2 bzip2 #:xz xz @@ -669,6 +698,7 @@ assumed to be part of MODULES." 'guix-daemon) #:info (info-manual source) + #:miscellany (miscellaneous-files source) #:guile-version guile-version))) ((= 0 pull-version) ;; Legacy 'guix pull': return the .scm and .go files as one @@ -687,7 +717,7 @@ assumed to be part of MODULES." (define %dependency-variables ;; (guix config) variables corresponding to dependencies. - '(%libgcrypt %libz %xz %gzip %bzip2)) + '(%libz %xz %gzip %bzip2)) (define %persona-variables ;; (guix config) variables that define Guix's persona. @@ -706,7 +736,7 @@ assumed to be part of MODULES." (variables rest ...)))))) (variables %localstatedir %storedir %sysconfdir %system))) -(define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 +(define* (make-config.scm #:key zlib gzip xz bzip2 (package-name "GNU Guix") (package-version "0") (bug-report-address "bug-guix@gnu.org") @@ -726,7 +756,6 @@ assumed to be part of MODULES." %state-directory %store-database-directory %config-directory - %libgcrypt %libz %gzip %bzip2 @@ -769,9 +798,6 @@ assumed to be part of MODULES." (define %xz #+(and xz (file-append xz "/bin/xz"))) - (define %libgcrypt - #+(and libgcrypt - (file-append libgcrypt "/lib/libgcrypt"))) (define %libz #+(and zlib (file-append zlib "/lib/libz")))) @@ -890,16 +916,9 @@ running Guile." 'canonical-package)) (match version - ("2.2.2" - ;; Gross hack to avoid ABI incompatibilities (see - ;; <https://bugs.gnu.org/29570>.) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2.2)) ("2.2" - ;; Use the latest version, which has fixes for - ;; <https://bugs.gnu.org/30602> and VM stack-marking issues. (canonical-package (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2.4))) + 'guile-2.2))) ("2.0" (module-ref (resolve-interface '(gnu packages guile)) 'guile-2.0)))) @@ -918,7 +937,11 @@ is not supported." version)) (define guile - (guile-for-build guile-version)) + ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2 + ;; unconditionally. + (guile-for-build (if (>= pull-version 1) + "2.2" + guile-version))) (mbegin %store-monad (set-guile-for-build guile) @@ -927,9 +950,8 @@ is not supported." #:name (string-append "guix-" (shorten version)) #:pull-version pull-version - #:guile-version (match guile-version - ("2.2.2" "2.2") - (version version)) + #:guile-version (if (>= pull-version 1) + "2.2" guile-version) #:guile-for-build guile))) (if guix (lower-object guix) diff --git a/guix/serialization.scm b/guix/serialization.scm index 129374f541..87ad7eeec0 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -301,8 +301,7 @@ result of 'lstat'; exclude entries for which SELECT? does not return true." (filter-map (lambda (base) (let ((file (string-append directory "/" base))) - (and (not (member base '("." ".."))) - (select? file (lstat file)) + (and (select? file (lstat file)) base))) basenames)) diff --git a/guix/ssh.scm b/guix/ssh.scm index da20d4d8db..104f4f52d6 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -161,7 +161,7 @@ Throw an error on failure." "/var/guix/daemon-socket/socket")) "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, an SSH session. Return a <nix-server> object." - (open-connection #:port (remote-daemon-channel session))) + (open-connection #:port (remote-daemon-channel session socket-name))) (define (store-import-channel session) @@ -297,9 +297,11 @@ Return the list of store items actually sent." (channel-send-eof port) ;; Wait for completion of the remote process and read the status sexp from - ;; PORT. + ;; PORT. Wait for the exit status only when 'read' completed; otherwise, + ;; we might wait forever if the other end is stuck. (let* ((result (false-if-exception (read port))) - (status (zero? (channel-get-exit-status port)))) + (status (and result + (zero? (channel-get-exit-status port))))) (close-port port) (match result (('success . _) diff --git a/guix/status.scm b/guix/status.scm new file mode 100644 index 0000000000..868bfdca21 --- /dev/null +++ b/guix/status.scm @@ -0,0 +1,620 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017, 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 status) + #:use-module (guix records) + #:use-module (guix i18n) + #:use-module ((guix ui) #:select (colorize-string)) + #:use-module (guix progress) + #:autoload (guix build syscalls) (terminal-columns) + #:use-module ((guix build download) + #:select (nar-uri-abbreviation)) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 binary-ports) + #:autoload (ice-9 rdelim) (read-string) + #:use-module (rnrs bytevectors) + #:use-module ((system foreign) + #:select (bytevector->pointer pointer->bytevector)) + #:export (build-event-output-port + compute-status + + build-status + build-status? + build-status-building + build-status-downloading + build-status-builds-completed + build-status-downloads-completed + + download? + download + download-item + download-uri + download-size + download-start + download-end + download-transferred + + build-status-updater + print-build-event + print-build-event/quiet + print-build-status + + with-status-report)) + +;;; Commentary: +;;; +;;; This module provides facilities to track the status of ongoing builds and +;;; downloads in a given session, as well as tools to report about the current +;;; status to user interfaces. It does so by analyzing the output of +;;; 'current-build-output-port'. The build status is maintained in a +;;; <build-status> record. +;;; +;;; Code: + + +;;; +;;; Build status tracking. +;;; + +;; Builds and substitutions performed by the daemon. +(define-record-type* <build-status> build-status make-build-status + build-status? + (building build-status-building ;list of drv + (default '())) + (downloading build-status-downloading ;list of <download> + (default '())) + (builds-completed build-status-builds-completed ;list of drv + (default '())) + (downloads-completed build-status-downloads-completed ;list of store items + (default '()))) + +;; On-going or completed downloads. Downloads can be stem from substitutes +;; and from "builtin:download" fixed-output derivations. +(define-record-type <download> + (%download item uri size start end transferred) + download? + (item download-item) ;store item + (uri download-uri) ;string | #f + (size download-size) ;integer | #f + (start download-start) ;<time> + (end download-end) ;#f | <time> + (transferred download-transferred)) ;integer + +(define* (download item uri + #:key size + (start (current-time time-monotonic)) end + (transferred 0)) + "Return a new download." + (%download item uri size start end transferred)) + +(define (matching-download item) + "Return a predicate that matches downloads of ITEM." + (lambda (download) + (string=? item (download-item download)))) + +(define* (compute-status event status + #:key + (current-time current-time) + (derivation-path->output-path + derivation-path->output-path)) + "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), +compute a new status based on STATUS." + (match event + (('build-started drv _ ...) + (build-status + (inherit status) + (building (cons drv (build-status-building status))))) + (((or 'build-succeeded 'build-failed) drv _ ...) + (build-status + (inherit status) + (building (delete drv (build-status-building status))) + (builds-completed (cons drv (build-status-builds-completed status))))) + + ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because + ;; they're not as informative as 'download-started' and + ;; 'download-succeeded'. + + (('download-started item uri (= string->number size)) + ;; This is presumably a fixed-output derivation so move it from + ;; 'building' to 'downloading'. XXX: This doesn't work in 'check' mode + ;; because ITEM is different from DRV's output. + (build-status + (inherit status) + (building (remove (lambda (drv) + (equal? (false-if-exception + (derivation-path->output-path drv)) + item)) + (build-status-building status))) + (downloading (cons (download item uri #:size size + #:start (current-time time-monotonic)) + (build-status-downloading status))))) + (('download-succeeded item uri (= string->number size)) + (let ((current (find (matching-download item) + (build-status-downloading status)))) + (build-status + (inherit status) + (downloading (delq current (build-status-downloading status))) + (downloads-completed + (cons (download item uri + #:size size + #:start (download-start current) + #:transferred size + #:end (current-time time-monotonic)) + (build-status-downloads-completed status)))))) + (('substituter-succeeded item _ ...) + (match (find (matching-download item) + (build-status-downloading status)) + (#f + ;; Presumably we already got a 'download-succeeded' event for ITEM, + ;; everything is fine. + status) + (current + ;; Maybe the build process didn't emit a 'download-succeeded' event + ;; for ITEM, so remove CURRENT from the queue now. + (build-status + (inherit status) + (downloading (delq current (build-status-downloading status))) + (downloads-completed + (cons (download item (download-uri current) + #:size (download-size current) + #:start (download-start current) + #:transferred (download-size current) + #:end (current-time time-monotonic)) + (build-status-downloads-completed status))))))) + (('download-progress item uri + (= string->number size) + (= string->number transferred)) + (let ((downloads (remove (matching-download item) + (build-status-downloading status))) + (current (find (matching-download item) + (build-status-downloading status)))) + (build-status + (inherit status) + (downloading (cons (download item uri + #:size size + #:start + (or (and current + (download-start current)) + (current-time time-monotonic)) + #:transferred transferred) + downloads))))) + (_ + status))) + +(define (simultaneous-jobs status) + "Return the number of on-going builds and downloads for STATUS." + (+ (length (build-status-building status)) + (length (build-status-downloading status)))) + + +;;; +;;; Rendering. +;;; + +(define (extended-build-trace-supported?) + "Return true if the currently used store is known to support \"extended +build traces\" such as \"@ download-progress\" traces." + ;; Support for extended build traces was added in protocol version #x162. + (and (current-store-protocol-version) + (>= (current-store-protocol-version) #x162))) + +(define (multiplexed-output-supported?) + "Return true if the daemon supports \"multiplexed output\"--i.e., \"@ +build-log\" traces." + (and (current-store-protocol-version) + (>= (current-store-protocol-version) #x163))) + +(define spin! + (let ((steps (circular-list "\\" "|" "/" "-"))) + (lambda (port) + "Display a spinner on PORT." + (match steps + ((first . rest) + (set! steps rest) + (display "\r\x1b[K" port) + (display first port) + (force-output port)))))) + +(define (color-output? port) + "Return true if we should write colored output to PORT." + (and (not (getenv "INSIDE_EMACS")) + (not (getenv "NO_COLOR")) + (isatty? port))) + +(define-syntax color-rules + (syntax-rules () + "Return a procedure that colorizes the string it is passed according to +the given rules. Each rule has the form: + + (REGEXP COLOR1 COLOR2 ...) + +where COLOR1 specifies how to colorize the first submatch of REGEXP, and so +on." + ((_ (regexp colors ...) rest ...) + (let ((next (color-rules rest ...)) + (rx (make-regexp regexp))) + (lambda (str) + (if (string-index str #\nul) + str + (match (regexp-exec rx str) + (#f (next str)) + (m (let loop ((n 1) + (c '(colors ...)) + (result '())) + (match c + (() + (string-concatenate-reverse result)) + ((first . tail) + (loop (+ n 1) tail + (cons (colorize-string (match:substring m n) + first) + result))))))))))) + ((_) + (lambda (str) + str)))) + +(define colorize-log-line + ;; Take a string and return a possibly colorized string according to the + ;; rules below. + (color-rules + ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)" + GREEN BOLD GREEN RESET GREEN BLUE) + ("^(phase)(.*)(failed after)(.*)(seconds)(.*)" + RED BLUE RED BLUE RED BLUE) + ("^(.*)(error|fail|failed|\\<FAIL|FAILED)([[:blank:]]*)(:)(.*)" + RESET RED BOLD BOLD BOLD) + ("^(.*)(warning)([[:blank:]]*)(:)(.*)" + RESET MAGENTA BOLD BOLD BOLD))) + +(define* (print-build-event event old-status status + #:optional (port (current-error-port)) + #:key + (colorize? (color-output? port)) + (print-log? #t)) + "Print information about EVENT and STATUS to PORT. When COLORIZE? is true, +produce colorful output. When PRINT-LOG? is true, display the build log in +addition to build events." + (define info + (if colorize? + (cut colorize-string <> 'BOLD) + identity)) + + (define success + (if colorize? + (cut colorize-string <> 'GREEN 'BOLD) + identity)) + + (define failure + (if colorize? + (cut colorize-string <> 'RED 'BOLD) + identity)) + + (define print-log-line + (if print-log? + (if colorize? + (lambda (line) + (display (colorize-log-line line) port)) + (cut display <> port)) + (lambda (line) + (spin! port)))) + + (unless print-log? + (display "\r" port)) ;erase the spinner + (match event + (('build-started drv . _) + (let ((properties (derivation-properties + (read-derivation-from-file drv)))) + (match (assq-ref properties 'type) + ('graft + (let ((count (match (assq-ref properties 'graft) + (#f 0) + (lst (or (assq-ref lst 'count) 0))))) + (format port (info (N_ "applying ~a graft for ~a..." + "applying ~a grafts for ~a..." + count)) + count drv))) + (_ + (format port (info (G_ "building ~a...")) drv)))) + (newline port)) + (('build-succeeded drv . _) + (when (or print-log? (not (extended-build-trace-supported?))) + (format port (success (G_ "successfully built ~a")) drv) + (newline port)) + (match (build-status-building status) + (() #t) + (ongoing ;when max-jobs > 1 + (format port + (N_ "The following build is still in progress:~%~{ ~a~%~}~%" + "The following builds are still in progress:~%~{ ~a~%~}~%" + (length ongoing)) + ongoing)))) + (('build-failed drv . _) + (format port (failure (G_ "build of ~a failed")) drv) + (newline port) + (match (derivation-log-file drv) + (#f + (format port (failure (G_ "Could not find build log for '~a'.")) + drv)) + (log + (format port (info (G_ "View build log at '~a'.")) log))) + (newline port)) + (('substituter-started item _ ...) + (when (or print-log? (not (extended-build-trace-supported?))) + (format port (info (G_ "substituting ~a...")) item) + (newline port))) + (('download-started item uri _ ...) + (format port (info (G_ "downloading from ~a...")) uri) + (newline port)) + (('download-progress item uri + (= string->number size) + (= string->number transferred)) + ;; Print a progress bar, but only if there's only one on-going + ;; job--otherwise the output would be intermingled. + (when (= 1 (simultaneous-jobs status)) + (match (find (matching-download item) + (build-status-downloading status)) + (#f #f) ;shouldn't happen! + (download + ;; XXX: It would be nice to memoize the abbreviation. + (let ((uri (if (string-contains uri "/nar/") + (nar-uri-abbreviation uri) + (basename uri)))) + (display-download-progress uri size + #:start-time + (download-start download) + #:transferred transferred)))))) + (('substituter-succeeded item _ ...) + ;; If there are no jobs running, we already reported download completion + ;; so there's nothing left to do. + (unless (and (zero? (simultaneous-jobs status)) + (extended-build-trace-supported?)) + (format port (success (G_ "substitution of ~a complete")) item) + (newline port))) + (('substituter-failed item _ ...) + (format port (failure (G_ "substitution of ~a failed")) item) + (newline port)) + (('hash-mismatch item algo expected actual _ ...) + ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for + ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm. + (format port (failure (G_ "~a hash mismatch for ~a:")) algo item) + (newline port) + (format port (info (G_ "\ + expected hash: ~a + actual hash: ~a~%")) + expected actual)) + (('build-remote drv host _ ...) + (format port (info (G_ "offloading build of ~a to '~a'")) drv host) + (newline port)) + (('build-log pid line) + (if (multiplexed-output-supported?) + (if (not pid) + (begin + ;; LINE comes from the daemon, not from builders. Let it + ;; through. + (display line port) + (force-output port)) + (print-log-line line)) + (cond ((string-prefix? "substitute: " line) + ;; The daemon prefixes early messages coming with 'guix + ;; substitute' with "substitute:". These are useful ("updating + ;; substitutes from URL"), so let them through. + (display line port) + (force-output port)) + ((string-prefix? "waiting for locks" line) + ;; This is when a derivation is already being built and we're just + ;; waiting for the build to complete. + (display (info (string-trim-right line)) port) + (newline)) + (else + (print-log-line line))))) + (_ + event))) + +(define* (print-build-event/quiet event old-status status + #:optional + (port (current-error-port)) + #:key + (colorize? (color-output? port))) + (print-build-event event old-status status port + #:colorize? colorize? + #:print-log? #f)) + +(define* (build-status-updater #:optional (on-change (const #t))) + "Return a procedure that can be passed to 'build-event-output-port'. That +procedure computes the new build status upon each event and calls ON-CHANGE: + + (ON-CHANGE event status new-status) + +ON-CHANGE can display the build status, build events, etc." + (lambda (event status) + (let ((new (compute-status event status))) + (on-change event status new) + new))) + + +;;; +;;; Build port. +;;; + +(define (maybe-utf8->string bv) + "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the +case where BV does not contain only valid UTF-8." + (catch 'decoding-error + (lambda () + (utf8->string bv)) + (lambda _ + ;; This is the sledgehammer but it's the only safe way we have to + ;; properly handle this. It's expensive but it's rarely needed. + (let ((port (open-bytevector-input-port bv))) + (set-port-encoding! port "UTF-8") + (set-port-conversion-strategy! port 'substitute) + (let ((str (read-string port))) + (close-port port) + str))))) + +(define (bytevector-index bv number offset count) + "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes; +return the offset where NUMBER first occurs or #f if it could not be found." + (let loop ((offset offset) + (count count)) + (cond ((zero? count) #f) + ((= (bytevector-u8-ref bv offset) number) offset) + (else (loop (+ 1 offset) (- count 1)))))) + +(define (split-lines str) + "Split STR into lines in a way that preserves newline characters." + (let loop ((str str) + (result '())) + (if (string-null? str) + (reverse result) + (match (string-index str #\newline) + (#f + (loop "" (cons str result))) + (index + (loop (string-drop str (+ index 1)) + (cons (string-take str (+ index 1)) result))))))) + +(define* (build-event-output-port proc #:optional (seed (build-status))) + "Return an output port for use as 'current-build-output-port' that calls +PROC with its current state value, initialized with SEED, on every build +event. Build events passed to PROC are tuples corresponding to the \"build +traces\" produced by the daemon: + + (build-started \"/gnu/store/...-foo.drv\" ...) + (substituter-started \"/gnu/store/...-foo\" ...) + +and so on. + +The second return value is a thunk to retrieve the current state." + (define %fragments + ;; Line fragments received so far. + '()) + + (define %state + ;; Current state for PROC. + seed) + + ;; When true, this represents the current state while reading a + ;; "@ build-log" trace: the current builder PID, the previously-read + ;; bytevectors, and the number of bytes that remain to be read. + (define %build-output-pid #f) + (define %build-output '()) + (define %build-output-left #f) + + (define (process-line line) + (cond ((string-prefix? "@ " line) + (match (string-tokenize (string-drop line 2)) + (("build-log" (= string->number pid) (= string->number len)) + (set! %build-output-pid pid) + (set! %build-output '()) + (set! %build-output-left len)) + (((= string->symbol event-name) args ...) + (set! %state + (proc (cons event-name args) + %state))))) + (else + (set! %state (proc (list 'build-log #f line) + %state))))) + + (define (process-build-output pid output) + ;; Transform OUTPUT in 'build-log' events or download events as generated + ;; by extended build traces. + (define (line->event line) + (match (and (string-prefix? "@ " line) + (string-tokenize (string-drop line 2))) + ((type . args) + (if (or (string-prefix? "download-" type) + (string=? "build-remote" type)) + (cons (string->symbol type) args) + `(build-log ,pid ,line))) + (_ + `(build-log ,pid ,line)))) + + (let* ((lines (split-lines output)) + (events (map line->event lines))) + (set! %state (fold proc %state events)))) + + (define (bytevector-range bv offset count) + (let ((ptr (bytevector->pointer bv offset))) + (pointer->bytevector ptr count))) + + (define (write! bv offset count) + (if %build-output-pid + (let ((keep (min count %build-output-left))) + (set! %build-output + (let ((bv* (make-bytevector keep))) + (bytevector-copy! bv offset bv* 0 keep) + (cons bv* %build-output))) + (set! %build-output-left + (- %build-output-left keep)) + + (when (zero? %build-output-left) + (process-build-output %build-output-pid + (string-concatenate-reverse + (map maybe-utf8->string %build-output))) ;XXX + (set! %build-output '()) + (set! %build-output-pid #f)) + keep) + (match (bytevector-index bv (char->integer #\newline) + offset count) + ((? integer? cr) + (let* ((tail (maybe-utf8->string + (bytevector-range bv offset (- cr -1 offset)))) + (line (string-concatenate-reverse + (cons tail %fragments)))) + (process-line line) + (set! %fragments '()) + (- cr -1 offset))) + (#f + (unless (zero? count) + (let ((str (maybe-utf8->string + (bytevector-range bv offset count)))) + (set! %fragments (cons str %fragments)))) + count)))) + + (define port + (make-custom-binary-output-port "filtering-input-port" + write! + #f #f + #f)) + + ;; The build port actually receives Unicode strings. + (set-port-encoding! port "UTF-8") + (cond-expand + ((and guile-2 (not guile-2.2)) #t) + (else (setvbuf port 'line))) + (values port (lambda () %state))) + +(define (call-with-status-report on-event thunk) + (parameterize ((current-terminal-columns (terminal-columns)) + (current-build-output-port + (build-event-output-port (build-status-updater on-event)))) + (thunk))) + +(define-syntax-rule (with-status-report on-event exp ...) + "Set up build status reporting to the user using the ON-EVENT procedure; +evaluate EXP... in that context." + (call-with-status-report on-event (lambda () exp ...))) diff --git a/guix/store.scm b/guix/store.scm index f41a1e2690..9dc651b26c 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -23,13 +23,15 @@ #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix monads) + #:use-module (guix records) #:use-module (guix base16) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix profiling) #:autoload (guix build syscalls) (terminal-columns) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) + #:use-module ((ice-9 control) #:select (let/ec)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -50,9 +52,12 @@ %default-substitute-urls nix-server? + nix-server-version nix-server-major-version nix-server-minor-version nix-server-socket + current-store-protocol-version ;for internal use + mcached &nix-error nix-error? &nix-connection-error nix-connection-error? @@ -150,9 +155,10 @@ store-path-package-name store-path-hash-part direct-store-path + derivation-log-file log-file)) -(define %protocol-version #x161) +(define %protocol-version #x163) (define %worker-magic-1 #x6e697863) ; "nixc" (define %worker-magic-2 #x6478696f) ; "dxio" @@ -161,6 +167,8 @@ (logand magic #xff00)) (define (protocol-minor magic) (logand magic #x00ff)) +(define (protocol-version major minor) + (logior major minor)) (define-syntax define-enumerate-type (syntax-rules () @@ -327,10 +335,7 @@ ;; remote-store.cc -(define-record-type <nix-server> - (%make-nix-server socket major minor - buffer flush - ats-cache atts-cache) +(define-record-type* <nix-server> nix-server %make-nix-server nix-server? (socket nix-server-socket) (major nix-server-major-version) @@ -343,7 +348,9 @@ ;; during the session are temporary GC roots kept for the duration of ;; the session. (ats-cache nix-server-add-to-store-cache) - (atts-cache nix-server-add-text-to-store-cache)) + (atts-cache nix-server-add-text-to-store-cache) + (object-cache nix-server-object-cache + (default vlist-null))) ;vhash (set-record-type-printer! <nix-server> (lambda (obj port) @@ -518,7 +525,8 @@ for this connection will be pinned. Return a server object." (protocol-minor v) output flush (make-hash-table 100) - (make-hash-table 100)))) + (make-hash-table 100) + vlist-null))) (let loop ((done? (process-stderr conn))) (or done? (process-stderr conn))) conn))))))))) @@ -538,7 +546,13 @@ connection. Use with care." (protocol-minor version) output flush (make-hash-table 100) - (make-hash-table 100)))) + (make-hash-table 100) + vlist-null))) + +(define (nix-server-version store) + "Return the protocol version of STORE as an integer." + (protocol-version (nix-server-major-version store) + (nix-server-minor-version store))) (define (write-buffered-output server) "Flush SERVER's output port." @@ -556,10 +570,20 @@ automatically close the store when the dynamic extent of EXP is left." (dynamic-wind (const #f) (lambda () - exp ...) + (parameterize ((current-store-protocol-version + (nix-server-version store))) + exp) ...) (lambda () (false-if-exception (close-connection store)))))) +(define current-store-protocol-version + ;; Protocol version of the store currently used. XXX: This is a hack to + ;; communicate the protocol version to the build output port. It's a hack + ;; because it could be inaccurrate, for instance if there's code that + ;; manipulates several store connections at once; it works well for the + ;; purposes of (guix status) though. + (make-parameter #f)) + (define current-build-output-port ;; The port where build output is sent. (make-parameter (current-error-port))) @@ -682,6 +706,22 @@ encoding conversion errors." (build-verbosity 0) (log-type 0) (print-build-trace #t) + + ;; When true, provide machine-readable "build + ;; traces" for use by (guix status). Old clients + ;; are unable to make sense, which is why it's + ;; disabled by default. + print-extended-build-trace? + + ;; When true, the daemon prefixes builder output + ;; with "@ build-log" traces so we can + ;; distinguish it from daemon output, and we can + ;; distinguish each builder's output + ;; (PRINT-BUILD-TRACE must be true as well.) The + ;; latter is particularly useful when + ;; MAX-BUILD-JOBS > 1. + multiplexed-build-output? + build-cores (use-substitutes? #t) @@ -725,7 +765,16 @@ encoding conversion errors." (when (>= (nix-server-minor-version server) 10) (send (boolean use-substitutes?))) (when (>= (nix-server-minor-version server) 12) - (let ((pairs `(,@(if timeout + (let ((pairs `(;; This option is honored by 'guix substitute' et al. + ,@(if print-build-trace + `(("print-extended-build-trace" + . ,(if print-extended-build-trace? "1" "0"))) + '()) + ,@(if multiplexed-build-output? + `(("multiplexed-build-output" + . ,(if multiplexed-build-output? "true" "false"))) + '()) + ,@(if timeout `(("build-timeout" . ,(number->string timeout))) '()) ,@(if max-silent-time @@ -770,6 +819,7 @@ bytevector) as its internal buffer, and a thunk to flush this output port." (define (flush) (put-bytevector port buffer 0 total) + (force-output port) (set! total 0)) (define (write bv offset count) @@ -927,6 +977,7 @@ path." (write-int (if recursive? 1 0) port) (write-string hash-algo port) (write-file file-name port #:select? select?) + (write-buffered-output server) (let loop ((done? (process-stderr server))) (or done? (loop (process-stderr server)))) (read-store-path port))))) @@ -1042,6 +1093,7 @@ an arbitrary directory layout in the store without creating a derivation." #:file-port file-port #:symlink-target symlink-target #:directory-entries directory-entries) + (write-buffered-output server) (let loop ((done? (process-stderr server))) (or done? (loop (process-stderr server)))) (let ((result (read-store-path port))) @@ -1061,13 +1113,15 @@ an arbitrary directory layout in the store without creating a derivation." outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Return #t on success." - (if (>= (nix-server-minor-version store) 15) - (build store things mode) - (if (= mode (build-mode normal)) - (build/old store things) - (raise (condition (&nix-protocol-error - (message "unsupported build mode") - (status 1))))))))) + (parameterize ((current-store-protocol-version + (nix-server-version store))) + (if (>= (nix-server-minor-version store) 15) + (build store things mode) + (if (= mode (build-mode normal)) + (build/old store things) + (raise (condition (&nix-protocol-error + (message "unsupported build mode") + (status 1)))))))))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. @@ -1436,6 +1490,56 @@ This makes sense only when the daemon was started with '--cache-failures'." ;; from %STATE-MONAD. (template-directory instantiations %store-monad) +(define* (cache-object-mapping object keys result) + "Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT. +KEYS is a list of additional keys to match against, for instance a (SYSTEM +TARGET) tuple. + +OBJECT is typically a high-level object such as a <package> or an <origin>, +and RESULT is typically its derivation." + (lambda (store) + (values result + (nix-server + (inherit store) + (object-cache (vhash-consq object (cons result keys) + (nix-server-object-cache store))))))) + +(define* (lookup-cached-object object #:optional (keys '())) + "Return the cached object in the store connection corresponding to OBJECT +and KEYS. KEYS is a list of additional keys to match against, and which are +compared with 'equal?'. Return #f on failure and the cached result +otherwise." + (lambda (store) + ;; Escape as soon as we find the result. This avoids traversing the whole + ;; vlist chain and significantly reduces the number of 'hashq' calls. + (values (let/ec return + (vhash-foldq* (lambda (item result) + (match item + ((value . keys*) + (if (equal? keys keys*) + (return value) + result)))) + #f object + (nix-server-object-cache store))) + store))) + +(define* (%mcached mthunk object #:optional (keys '())) + "Bind the monadic value returned by MTHUNK, which supposedly corresponds to +OBJECT/KEYS, or return its cached value." + (mlet %store-monad ((cached (lookup-cached-object object keys))) + (if cached + (return cached) + (>>= (mthunk) + (lambda (result) + (cache-object-mapping object keys result)))))) + +(define-syntax-rule (mcached mvalue object keys ...) + "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the +value associated with OBJECT/KEYS in the store's object cache if there is +one." + (%mcached (lambda () mvalue) + object (list keys ...))) + (define (preserve-documentation original proc) "Return PROC with documentation taken from ORIGINAL." (set-object-property! proc 'documentation @@ -1670,21 +1774,26 @@ syntactically valid store path." (and (string-every %nix-base32-charset hash) hash)))))) +(define (derivation-log-file drv) + "Return the build log file for DRV, a derivation file name, or #f if it +could not be found." + (let* ((base (basename drv)) + (log (string-append (dirname %state-directory) ; XXX + "/log/guix/drvs/" + (string-take base 2) "/" + (string-drop base 2))) + (log.gz (string-append log ".gz")) + (log.bz2 (string-append log ".bz2"))) + (cond ((file-exists? log.gz) log.gz) + ((file-exists? log.bz2) log.bz2) + ((file-exists? log) log) + (else #f)))) + (define (log-file store file) "Return the build log file for FILE, or #f if none could be found. FILE must be an absolute store file name, or a derivation file name." (cond ((derivation-path? file) - (let* ((base (basename file)) - (log (string-append (dirname %state-directory) ; XXX - "/log/guix/drvs/" - (string-take base 2) "/" - (string-drop base 2))) - (log.gz (string-append log ".gz")) - (log.bz2 (string-append log ".bz2"))) - (cond ((file-exists? log.gz) log.gz) - ((file-exists? log.bz2) log.bz2) - ((file-exists? log) log) - (else #f)))) + (derivation-log-file file)) (else (match (valid-derivers store file) ((derivers ...) diff --git a/guix/store/database.scm b/guix/store/database.scm index 0879a95d0b..e6bfbe763e 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -23,6 +23,7 @@ #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) + #:use-module (guix progress) #:use-module (guix build syscalls) #:use-module ((guix build utils) #:select (mkdir-p executable-file?)) @@ -35,7 +36,9 @@ #:use-module (ice-9 match) #:use-module (system foreign) #:export (sql-schema + %default-database-file with-database + path-id sqlite-register register-path register-items @@ -50,7 +53,7 @@ (define sqlite-exec ;; XXX: This is was missing from guile-sqlite3 until - ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. + ;; <https://notabug.org/guile-sqlite3/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>. (let ((exec (pointer->procedure int (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3)) @@ -84,6 +87,10 @@ create it and initialize it as a new database." (lambda () (sqlite-close db))))) +(define %default-database-file + ;; Default location of the store database. + (string-append %store-database-directory "/db.sqlite")) + (define-syntax-rule (with-database file db exp ...) "Open DB from FILE and close it when the dynamic extent of EXP... is left. If FILE doesn't exist, create it and initialize it as a new database." @@ -234,7 +241,8 @@ be used internally by the daemon's build hook." #:prefix prefix #:state-directory state-directory #:deduplicate? deduplicate? #:reset-timestamps? reset-timestamps? - #:schema schema)) + #:schema schema + #:log-port (%make-void-port "w"))) (define %epoch ;; When it all began. @@ -245,12 +253,14 @@ be used internally by the daemon's build hook." (deduplicate? #t) (reset-timestamps? #t) registration-time - (schema (sql-schema))) + (schema (sql-schema)) + (log-port (current-error-port))) "Register all of ITEMS, a list of <store-info> records as returned by 'read-reference-graph', in the database under PREFIX/STATE-DIRECTORY. ITEMS must be in topological order (with leaves first.) If the database is initially empty, apply SCHEMA to initialize it. REGISTRATION-TIME must be the -registration time to be recorded in the database; #f means \"now\"." +registration time to be recorded in the database; #f means \"now\". +Write a progress report to LOG-PORT." ;; Priority for options: first what is given, then environment variables, ;; then defaults. %state-directory, %store-directory, and @@ -286,20 +296,32 @@ registration time to be recorded in the database; #f means \"now\"." (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) - (let-values (((hash nar-size) (nar-sha256 real-file-name))) + ;; When TO-REGISTER is already registered, skip it. This makes a + ;; significant differences when 'register-closures' is called + ;; consecutively for overlapping closures such as 'system' and 'bootcfg'. + (unless (path-id db to-register) (when reset-timestamps? (reset-timestamps real-file-name)) - (sqlite-register db #:path to-register - #:references (store-info-references item) - #:deriver (store-info-deriver item) - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size - #:time registration-time) - (when deduplicate? - (deduplicate real-file-name hash #:store store-dir)))) + (let-values (((hash nar-size) (nar-sha256 real-file-name))) + (sqlite-register db #:path to-register + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:hash (string-append "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size + #:time registration-time) + (when deduplicate? + (deduplicate real-file-name hash #:store store-dir))))) (mkdir-p db-dir) (parameterize ((sql-schema schema)) (with-database (string-append db-dir "/db.sqlite") db - (for-each (cut register db <>) items)))) + (let* ((prefix (format #f "registering ~a items" (length items))) + (progress (progress-reporter/bar (length items) + prefix log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (item) + (register db item) + (report)) + items))))))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 8c19d7309e..21b0c81f3d 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -21,7 +21,7 @@ ;;; timestamps, deduplicating, etc. (define-module (guix store deduplication) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix build utils) #:use-module (guix base16) #:use-module (srfi srfi-11) @@ -102,11 +102,17 @@ LINK-PREFIX." SWAP-DIRECTORY as the directory to store temporary hard links. Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." - (let ((temp-link (get-temp-link target swap-directory))) - (make-file-writable (dirname to-replace)) + (let* ((temp-link (get-temp-link target swap-directory)) + (parent (dirname to-replace)) + (stat (stat parent))) + (make-file-writable parent) (catch 'system-error (lambda () - (rename-file temp-link to-replace)) + (rename-file temp-link to-replace) + + ;; Restore PARENT's mtime and permissions. + (set-file-time parent stat) + (chmod parent (stat:mode stat))) (lambda args (delete-file temp-link) (unless (= EMLINK (system-error-errno args)) diff --git a/guix/swh.scm b/guix/swh.scm new file mode 100644 index 0000000000..89cddb2bdd --- /dev/null +++ b/guix/swh.scm @@ -0,0 +1,560 @@ +;;; GNU Guix --- Functional package management for GNU +;;; 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 swh) + #:use-module (guix base16) + #:use-module (guix build utils) + #:use-module ((guix build syscalls) #:select (mkdtemp!)) + #:use-module (web client) + #:use-module (web response) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) + #:use-module ((ice-9 ftw) #:select (scandir)) + #:export (origin? + origin-id + origin-type + origin-url + origin-visits + lookup-origin + + visit? + visit-date + visit-origin + visit-url + visit-snapshot-url + visit-status + visit-number + visit-snapshot + + branch? + branch-name + branch-target + + release? + release-id + release-name + release-message + release-target + + revision? + revision-id + revision-date + revision-directory + lookup-revision + lookup-origin-revision + + content? + content-checksums + content-data-url + content-length + lookup-content + + directory-entry? + directory-entry-name + directory-entry-type + directory-entry-checksums + directory-entry-length + directory-entry-permissions + lookup-directory + directory-entry-target + + save-reply? + save-reply-origin-url + save-reply-origin-type + save-reply-request-date + save-reply-request-status + save-reply-task-status + save-origin + save-origin-status + + vault-reply? + vault-reply-id + vault-reply-fetch-url + vault-reply-object-id + vault-reply-object-type + vault-reply-progress-message + vault-reply-status + query-vault + request-cooking + vault-fetch + + swh-download)) + +;;; Commentary: +;;; +;;; This module provides bindings to the HTTP interface of Software Heritage. +;;; It allows you to browse the archive, look up revisions (such as SHA1 +;;; commit IDs), "origins" (code hosting URLs), content (files), etc. See +;;; <https://archive.softwareheritage.org/api/> for more information. +;;; +;;; The high-level 'swh-download' procedure allows you to download a Git +;;; revision from Software Heritage, provided it is available. +;;; +;;; Code: + +(define %swh-base-url + ;; Presumably we won't need to change it. + "https://archive.softwareheritage.org") + +(define (swh-url path . rest) + (define url + (string-append %swh-base-url path + (string-join rest "/" 'prefix))) + + ;; Ensure there's a trailing slash or we get a redirect. + (if (string-suffix? "/" url) + url + (string-append url "/"))) + +(define-syntax-rule (define-json-reader json->record ctor spec ...) + "Define JSON->RECORD as a procedure that converts a JSON representation, +read from a port, string, or hash table, into a record created by CTOR and +following SPEC, a series of field specifications." + (define (json->record input) + (let ((table (cond ((port? input) + (json->scm input)) + ((string? input) + (json-string->scm input)) + ((hash-table? input) + input)))) + (let-syntax ((extract-field (syntax-rules () + ((_ table (field key json->value)) + (json->value (hash-ref table key))) + ((_ table (field key)) + (hash-ref table key)) + ((_ table (field)) + (hash-ref table + (symbol->string 'field)))))) + (ctor (extract-field table spec) ...))))) + +(define-syntax-rule (define-json-mapping rtd ctor pred json->record + (field getter spec ...) ...) + "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9, +and define JSON->RECORD as a conversion from JSON to a record of this type." + (begin + (define-record-type rtd + (ctor field ...) + pred + (field getter) ...) + + (define-json-reader json->record ctor + (field spec ...) ...))) + +(define %date-regexp + ;; Match strings like "2014-11-17T22:09:38+01:00" or + ;; "2018-09-30T23:20:07.815449+00:00"". + (make-regexp "^([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})((\\.[0-9]+)?)([+-][0-9]{2}):([0-9]{2})$")) + +(define (string->date* str) + "Return a SRFI-19 date parsed from STR, a date string as returned by +Software Heritage." + ;; We can't use 'string->date' because of the timezone format: SWH returns + ;; "+01:00" when the '~z' template expects "+0100". So we roll our own! + (or (and=> (regexp-exec %date-regexp str) + (lambda (match) + (define (ref n) + (string->number (match:substring match n))) + + (make-date (let ((ns (match:substring match 8))) + (if ns + (string->number (string-drop ns 1)) + 0)) + (ref 6) (ref 5) (ref 4) + (ref 3) (ref 2) (ref 1) + (+ (* 3600 (ref 9)) ;time zone + (if (< (ref 9) 0) + (- (ref 10)) + (ref 10)))))) + str)) ;oops! + +(define* (call url decode #:optional (method http-get) + #:key (false-if-404? #t)) + "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body +using DECODE, a one-argument procedure that takes an input port. When +FALSE-IF-404? is true, return #f upon 404 responses." + (let*-values (((response port) + (method url #:streaming? #t))) + ;; See <https://archive.softwareheritage.org/api/#rate-limiting>. + (match (assq-ref (response-headers response) 'x-ratelimit-remaining) + (#f #t) + ((? (compose zero? string->number)) + (throw 'swh-error url response)) + (_ #t)) + + (cond ((= 200 (response-code response)) + (let ((result (decode port))) + (close-port port) + result)) + ((and false-if-404? + (= 404 (response-code response))) + (close-port port) + #f) + (else + (close-port port) + (throw 'swh-error url response))))) + +(define-syntax define-query + (syntax-rules (path) + "Define a procedure that performs a Software Heritage query." + ((_ (name args ...) docstring (path components ...) + json->value) + (define (name args ...) + docstring + (call (swh-url components ...) json->value))))) + +;; <https://archive.softwareheritage.org/api/1/origin/git/url/https://github.com/guix-mirror/guix/> +(define-json-mapping <origin> make-origin origin? + json->origin + (id origin-id) + (visits-url origin-visits-url "origin_visits_url") + (type origin-type) + (url origin-url)) + +;; <https://archive.softwareheritage.org/api/1/origin/52181937/visits/> +(define-json-mapping <visit> make-visit visit? + json->visit + (date visit-date "date" string->date*) + (origin visit-origin) + (url visit-url "origin_visit_url") + (snapshot-url visit-snapshot-url "snapshot_url") + (status visit-status) + (number visit-number "visit")) + +;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/> +(define-json-mapping <snapshot> make-snapshot snapshot? + json->snapshot + (branches snapshot-branches "branches" json->branches)) + +;; This is used for the "branches" field of snapshots. +(define-record-type <branch> + (make-branch name target-type target-url) + branch? + (name branch-name) + (target-type branch-target-type) ;release | revision + (target-url branch-target-url)) + +(define (json->branches branches) + (hash-map->list (lambda (key value) + (make-branch key + (string->symbol + (hash-ref value "target_type")) + (hash-ref value "target_url"))) + branches)) + +;; <https://archive.softwareheritage.org/api/1/release/1f44934fb6e2cefccbecd4fa347025349fa9ff76/> +(define-json-mapping <release> make-release release? + json->release + (id release-id) + (name release-name) + (message release-message) + (target-type release-target-type "target_type" string->symbol) + (target-url release-target-url "target_url")) + +;; <https://archive.softwareheritage.org/api/1/revision/359fdda40f754bbf1b5dc261e7427b75463b59be/> +(define-json-mapping <revision> make-revision revision? + json->revision + (id revision-id) + (date revision-date "date" string->date*) + (directory revision-directory) + (directory-url revision-directory-url "directory_url")) + +;; <https://archive.softwareheritage.org/api/1/content/> +(define-json-mapping <content> make-content content? + json->content + (checksums content-checksums "checksums" json->checksums) + (data-url content-data-url "data_url") + (file-type-url content-file-type-url "filetype_url") + (language-url content-language-url "language_url") + (length content-length) + (license-url content-license-url "license_url")) + +(define (json->checksums checksums) + (hash-map->list (lambda (key value) + (cons key (base16-string->bytevector value))) + checksums)) + +;; <https://archive.softwareheritage.org/api/1/directory/27c69c5d298a43096a53affbf881e7b13f17bdcd/> +(define-json-mapping <directory-entry> make-directory-entry directory-entry? + json->directory-entry + (name directory-entry-name) + (type directory-entry-type "type" + (match-lambda + ("dir" 'directory) + (str (string->symbol str)))) + (checksums directory-entry-checksums "checksums" + (match-lambda + (#f #f) + (lst (json->checksums lst)))) + (id directory-entry-id "dir_id") + (length directory-entry-length) + (permissions directory-entry-permissions "perms") + (target-url directory-entry-target-url "target_url")) + +;; <https://archive.softwareheritage.org/api/1/origin/save/> +(define-json-mapping <save-reply> make-save-reply save-reply? + json->save-reply + (origin-url save-reply-origin-url "origin_url") + (origin-type save-reply-origin-type "origin_type") + (request-date save-reply-request-date "save_request_date" + string->date*) + (request-status save-reply-request-status "save_request_status" + string->symbol) + (task-status save-reply-task-status "save_task_status" + (match-lambda + ("not created" 'not-created) + ((? string? str) (string->symbol str))))) + +;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref> +(define-json-mapping <vault-reply> make-vault-reply vault-reply? + json->vault-reply + (id vault-reply-id) + (fetch-url vault-reply-fetch-url "fetch_url") + (object-id vault-reply-object-id "obj_id") + (object-type vault-reply-object-type "obj_type" string->symbol) + (progress-message vault-reply-progress-message "progress_message") + (status vault-reply-status "status" string->symbol)) + + +;;; +;;; RPCs. +;;; + +(define-query (lookup-origin url) + "Return an origin for URL." + (path "/api/1/origin/git/url" url) + json->origin) + +(define-query (lookup-content hash type) + "Return a content for HASH, of the given TYPE--e.g., \"sha256\"." + (path "/api/1/content" + (string-append type ":" + (bytevector->base16-string hash))) + json->content) + +(define-query (lookup-revision id) + "Return the revision with the given ID, typically a Git commit SHA1." + (path "/api/1/revision" id) + json->revision) + +(define-query (lookup-directory id) + "Return the directory with the given ID." + (path "/api/1/directory" id) + json->directory-entries) + +(define (json->directory-entries port) + (map json->directory-entry (json->scm port))) + +(define (origin-visits origin) + "Return the list of visits of ORIGIN, a record as returned by +'lookup-origin'." + (call (swh-url (origin-visits-url origin)) + (lambda (port) + (map json->visit (json->scm port))))) + +(define (visit-snapshot visit) + "Return the snapshot corresponding to VISIT." + (call (swh-url (visit-snapshot-url visit)) + json->snapshot)) + +(define (branch-target branch) + "Return the target of BRANCH, either a <revision> or a <release>." + (match (branch-target-type branch) + ('release + (call (swh-url (branch-target-url branch)) + json->release)) + ('revision + (call (swh-url (branch-target-url branch)) + json->revision)))) + +(define (lookup-origin-revision url tag) + "Return a <revision> corresponding to the given TAG for the repository +coming from URL. Example: + + (lookup-origin-release \"https://github.com/guix-mirror/guix/\" \"v0.8\") + => #<<revision> id: \"44941…\" …> + +The information is based on the latest visit of URL available. Return #f if +URL could not be found." + (match (lookup-origin url) + (#f #f) + (origin + (match (origin-visits origin) + ((visit . _) + (let ((snapshot (visit-snapshot visit))) + (match (and=> (find (lambda (branch) + (string=? (string-append "refs/tags/" tag) + (branch-name branch))) + (snapshot-branches snapshot)) + branch-target) + ((? release? release) + (release-target release)) + ((? revision? revision) + revision) + (#f ;tag not found + #f)))) + (() + #f))))) + +(define (release-target release) + "Return the revision that is the target of RELEASE." + (match (release-target-type release) + ('revision + (call (swh-url (release-target-url release)) + json->revision)))) + +(define (directory-entry-target entry) + "If ENTRY, a directory entry, has type 'directory, return its list of +directory entries; if it has type 'file, return its <content> object." + (call (swh-url (directory-entry-target-url entry)) + (match (directory-entry-type entry) + ('file json->content) + ('directory json->directory-entries)))) + +(define* (save-origin url #:optional (type "git")) + "Request URL to be saved." + (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply + http-post)) + +(define-query (save-origin-status url type) + "Return the status of a /save request for URL and TYPE (e.g., \"git\")." + (path "/api/1/origin/save" type "url" url) + json->save-reply) + +(define-query (query-vault id kind) + "Ask the availability of object ID and KIND to the vault, where KIND is +'directory or 'revision. Return #f if it could not be found, or a +<vault-reply> on success." + ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref> + ;; There's a single format supported for directories and revisions and for + ;; now, the "/format" bit of the URL *must* be omitted. + (path "/api/1/vault" (symbol->string kind) id) + json->vault-reply) + +(define (request-cooking id kind) + "Request the cooking of object ID and KIND (one of 'directory or 'revision) +to the vault. Return a <vault-reply>." + (call (swh-url "/api/1/vault" (symbol->string kind) id) + json->vault-reply + http-post)) + +(define* (vault-fetch id kind + #:key (log-port (current-error-port))) + "Return an input port from which a bundle of the object with the given ID +and KIND (one of 'directory or 'revision) can be retrieved, or #f if the +object could not be found. + +For a directory, the returned stream is a gzip-compressed tarball. For a +revision, it is a gzip-compressed stream for 'git fast-import'." + (let loop ((reply (query-vault id kind))) + (match reply + (#f + (and=> (request-cooking id kind) loop)) + (_ + (match (vault-reply-status reply) + ('done + ;; Fetch the bundle. + (let-values (((response port) + (http-get (swh-url (vault-reply-fetch-url reply)) + #:streaming? #t))) + (if (= (response-code response) 200) + port + (begin ;shouldn't happen + (close-port port) + #f)))) + ('failed + ;; Upon failure, we're supposed to try again. + (format log-port "SWH vault: failure: ~a~%" + (vault-reply-progress-message reply)) + (format log-port "SWH vault: retrying...~%") + (loop (request-cooking id kind))) + ((and (or 'new 'pending) status) + ;; Wait until the bundle shows up. + (let ((message (vault-reply-progress-message reply))) + (when (eq? 'new status) + (format log-port "SWH vault: \ +requested bundle cooking, waiting for completion...~%")) + (when (string? message) + (format log-port "SWH vault: ~a~%" message)) + + ;; Wait long enough so we don't exhaust our maximum number of + ;; requests per hour too fast (as of this writing, the limit is 60 + ;; requests per hour per IP address.) + (sleep (if (eq? status 'new) 60 30)) + + (loop (query-vault id kind))))))))) + + +;;; +;;; High-level interface. +;;; + +(define (commit-id? reference) + "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if +it is a tag name." + (and (= (string-length reference) 40) + (string-every char-set:hex-digit reference))) + +(define (call-with-temporary-directory proc) ;FIXME: factorize + "Call PROC with a name of a temporary directory; close the directory and +delete it when leaving the dynamic extent of this call." + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-directory.XXXXXX")) + (tmp-dir (mkdtemp! template))) + (dynamic-wind + (const #t) + (lambda () + (proc tmp-dir)) + (lambda () + (false-if-exception (delete-file-recursively tmp-dir)))))) + +(define (swh-download url reference output) + "Download from Software Heritage a checkout of the Git tag or commit +REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success +and #f on failure. + +This procedure uses the \"vault\", which contains \"cooked\" directories in +the form of tarballs. If the requested directory is not cooked yet, it will +wait until it becomes available, which could take several minutes." + (match (if (commit-id? reference) + (lookup-revision reference) + (lookup-origin-revision url reference)) + ((? revision? revision) + (call-with-temporary-directory + (lambda (directory) + (let ((input (vault-fetch (revision-directory revision) 'directory)) + (tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) + (dump-port input tar) + (close-port input) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + + (match (scandir directory) + (("." ".." sub-directory) + (copy-recursively (string-append directory "/" sub-directory) + output + #:log (%make-void-port "w")) + #t)))))) + (#f + #f))) diff --git a/guix/tests.scm b/guix/tests.scm index 34e3e0fc2a..f4948148c4 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,26 +17,32 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix tests) + #:use-module ((guix config) #:select (%storedir %localstatedir)) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix base32) #:use-module (guix serialization) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix build-system gnu) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (web uri) #:export (open-connection-for-tests + with-external-store random-text random-bytevector file=? + canonical-file? network-reachable? shebang-too-long? mock %test-substitute-urls + test-assertm + test-equalm %substitute-directory with-derivation-narinfo with-derivation-substitute @@ -74,6 +80,39 @@ store))) +(define (call-with-external-store proc) + "Call PROC with an open connection to the external store or #f it there is +no external store to talk to." + (parameterize ((%daemon-socket-uri + (string-append %localstatedir + "/guix/daemon-socket/socket")) + (%store-prefix %storedir)) + (define store + (catch #t + (lambda () + (open-connection)) + (const #f))) + + (dynamic-wind + (const #t) + (lambda () + ;; Since we're using a different store we must clear the + ;; package-derivation cache. + (hash-clear! (@@ (guix packages) %derivation-cache)) + + (proc store)) + (lambda () + (when store + (close-connection store)))))) + +(define-syntax-rule (with-external-store store exp ...) + "Evaluate EXP with STORE bound to the external store rather than the +temporary test store, or #f if there is no external store to talk to. + +This is meant to be used for tests that need to build packages that would be +too expensive to build entirely in the test store." + (call-with-external-store (lambda (store) exp ...))) + (define (random-seed) (or (and=> (getenv "GUIX_TESTS_RANDOM_SEED") number->string) @@ -112,6 +151,14 @@ (else (error "what?" (lstat a)))))) +(define (canonical-file? file) + "Return #t if FILE is in the store, is read-only, and its mtime is 1." + (let ((st (lstat file))) + (or (not (string-prefix? (%store-prefix) file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 (stat:mode st))))))) + (define (network-reachable?) "Return true if we can reach the Internet." (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) @@ -126,6 +173,28 @@ given by REPLACEMENT." (lambda () body ...) (lambda () (module-set! m 'proc original))))) +(define-syntax-rule (test-assertm name exp) + "Like 'test-assert', but EXP is a monadic value. A new connection to the +store is opened." + (test-assert name + (let ((store (open-connection-for-tests))) + (dynamic-wind + (const #t) + (lambda () + (run-with-store store exp + #:guile-for-build (%guile-for-build))) + (lambda () + (close-connection store)))))) + +(define-syntax-rule (test-equalm name value exp) + "Like 'test-equal', but EXP is a monadic value. A new connection to the +store is opened." + (test-equal name + value + (with-store store + (run-with-store store exp + #:guile-for-build (%guile-for-build))))) + ;;; ;;; Narinfo files, as used by the substituter. diff --git a/guix/ui.scm b/guix/ui.scm index 29c0b2b9ce..60636edac0 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -10,6 +10,9 @@ ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2013, 2014 Free Software Foundation, Inc. +;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,7 +118,8 @@ guix-warning-port warning info - guix-main)) + guix-main + colorize-string)) ;;; Commentary: ;;; @@ -812,6 +816,12 @@ warning." (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%") (/ need 1e6) (/ free 1e6) directory)))) +(define (graft-derivation? drv) + "Return true if DRV is definitely a graft derivation, false otherwise." + (match (assq-ref (derivation-properties drv) 'type) + ('graft #t) + (_ #f))) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) (mode (build-mode normal))) @@ -861,7 +871,11 @@ report what is prerequisites are available for download." (append-map substitutable-references download)))) - download))) + download)) + ((graft build) + (partition (compose graft-derivation? + read-derivation-from-file) + build))) (define installed-size (reduce + 0 (map substitutable-nar-size download))) @@ -894,7 +908,12 @@ report what is prerequisites are available for download." "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download)))) + (map substitutable-path download))) + (format (current-error-port) + (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) graft)) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" @@ -914,7 +933,12 @@ report what is prerequisites are available for download." "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download))))) + (map substitutable-path download))) + (format (current-error-port) + (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) graft))) (check-available-space installed-size) @@ -1622,4 +1646,54 @@ and signal handling has already been set up." (initialize-guix) (apply run-guix args)) +(define color-table + `((CLEAR . "0") + (RESET . "0") + (BOLD . "1") + (DARK . "2") + (UNDERLINE . "4") + (UNDERSCORE . "4") + (BLINK . "5") + (REVERSE . "6") + (CONCEALED . "8") + (BLACK . "30") + (RED . "31") + (GREEN . "32") + (YELLOW . "33") + (BLUE . "34") + (MAGENTA . "35") + (CYAN . "36") + (WHITE . "37") + (ON-BLACK . "40") + (ON-RED . "41") + (ON-GREEN . "42") + (ON-YELLOW . "43") + (ON-BLUE . "44") + (ON-MAGENTA . "45") + (ON-CYAN . "46") + (ON-WHITE . "47"))) + +(define (color . lst) + "Return a string containing the ANSI escape sequence for producing the +requested set of attributes in LST. Unknown attributes are ignored." + (let ((color-list + (remove not + (map (lambda (color) (assq-ref color-table color)) + lst)))) + (if (null? color-list) + "" + (string-append + (string #\esc #\[) + (string-join color-list ";" 'infix) + "m")))) + +(define (colorize-string str . color-list) + "Return a copy of STR colorized using ANSI escape sequences according to the +attributes STR. At the end of the returned string, the color attributes will +be reset such that subsequent output will not have any colors in effect." + (string-append + (apply color color-list) + str + (color 'RESET))) + ;;; ui.scm ends here |