diff options
Diffstat (limited to 'guix')
51 files changed, 2904 insertions, 558 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/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/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/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/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/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 7b556f6431..23d97e6602 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -239,7 +239,7 @@ 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. - (unless (file-exists? config-file) + (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 <>)))) 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/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/store-copy.scm b/guix/build/store-copy.scm index 64ade7885c..549aa4f28b 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -168,6 +168,28 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) +(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 @@ -197,7 +219,13 @@ REFERENCE-GRAPHS, a list of reference-graph files." (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))))) diff --git a/guix/channels.scm b/guix/channels.scm index 82389eb583..75503bb0ae 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ #:use-module (guix store) #:use-module (guix i18n) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:autoload (guix self) (whole-package) @@ -47,6 +49,7 @@ channel-instance-checkout latest-channel-instances + checkout->channel-instance latest-channel-derivation channel-instances->manifest channel-instances->derivation)) @@ -72,7 +75,6 @@ (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. @@ -92,6 +94,12 @@ (commit channel-instance-commit) (checkout channel-instance-checkout)) +(define-record-type <channel-metadata> + (channel-metadata version dependencies) + channel-metadata? + (version channel-metadata-version) + (dependencies channel-metadata-dependencies)) + (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for 'latest-repository-commit'." @@ -99,20 +107,101 @@ (#f `(branch . ,(channel-branch channel))) (commit `(commit . ,(channel-commit channel))))) -(define (latest-channel-instances store channels) +(define (read-channel-metadata instance) + "Return a channel-metadata record read from the channel INSTANCE's +description file, or return #F if the channel instance does not include the +file." + (let* ((source (channel-instance-checkout instance)) + (meta-file (string-append source "/.guix-channel"))) + (and (file-exists? meta-file) + (and-let* ((raw (call-with-input-file meta-file read)) + (version (and=> (assoc-ref raw 'version) first)) + (dependencies (or (assoc-ref raw 'dependencies) '()))) + (channel-metadata + version + (map (lambda (item) + (let ((get (lambda* (key #:optional default) + (or (and=> (assoc-ref item key) first) default)))) + (and-let* ((name (get 'name)) + (url (get 'url)) + (branch (get 'branch "master"))) + (channel + (name name) + (branch branch) + (url url) + (commit (get 'commit)))))) + dependencies)))))) + +(define (channel-instance-dependencies instance) + "Return the list of channels that are declared as dependencies for the given +channel INSTANCE." + (match (read-channel-metadata instance) + (#f '()) + (($ <channel-metadata> version dependencies) + dependencies))) + +(define* (latest-channel-instances store channels #:optional (previous-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)) +CHANNELS and the channels on which they depend. PREVIOUS-CHANNELS is a list +of previously processed channels." + ;; Only process channels that are unique, or that are more specific than a + ;; previous channel specification. + (define (ignore? channel others) + (member channel others + (lambda (a b) + (and (eq? (channel-name a) (channel-name b)) + (or (channel-commit b) + (not (or (channel-commit a) + (channel-commit b)))))))) + ;; Accumulate a list of instances. A list of processed channels is also + ;; accumulated to decide on duplicate channel specifications. + (match (fold (lambda (channel acc) + (match acc + ((#:channels previous-channels #:instances instances) + (if (ignore? channel previous-channels) + acc + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let-values (((checkout commit) + (latest-repository-commit store (channel-url channel) + #:ref (channel-reference + channel)))) + (let ((instance (channel-instance channel commit checkout))) + (let-values (((new-instances new-channels) + (latest-channel-instances + store + (channel-instance-dependencies instance) + previous-channels))) + `(#:channels + ,(append (cons channel new-channels) + previous-channels) + #:instances + ,(append (cons instance new-instances) + instances)))))))))) + `(#:channels ,previous-channels #:instances ()) + channels) + ((#:channels channels #:instances instances) + (let ((instance-name (compose channel-name channel-instance-channel))) + ;; Remove all earlier channel specifications if they are followed by a + ;; more specific one. + (values (delete-duplicates instances + (lambda (a b) + (eq? (instance-name a) (instance-name b)))) + channels))))) + +(define* (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 @@ -223,8 +312,21 @@ INSTANCES." (lambda (instance) (if (eq? instance core-instance) (return core) - (build-channel-instance instance - (cons core dependencies)))) + (match (channel-instance-dependencies instance) + (() + (build-channel-instance instance + (cons core dependencies))) + (channels + (mlet %store-monad ((dependencies-derivation + (latest-channel-derivation + ;; %default-channels is used here to + ;; ensure that the core channel is + ;; available for channels declared as + ;; dependencies. + (append channels %default-channels)))) + (build-channel-instance instance + (cons dependencies-derivation + (cons core dependencies)))))))) instances))) (define (whole-package-for-legacy name modules) 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/derivations.scm b/guix/derivations.scm index 7afecb10cc..f6176a78fd 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -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/docker.scm b/guix/docker.scm index 0757d3356f..c6e9c6fee5 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -26,6 +26,7 @@ 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/gexp.scm b/guix/gexp.scm index f7def5862b..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) @@ -506,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) @@ -524,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? @@ -609,6 +631,8 @@ names and file names suitable for the #:allowed-references argument to allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) + (properties '()) + deprecation-warnings (script-name (string-append name "-builder"))) "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a @@ -766,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 diff --git a/guix/git-download.scm b/guix/git-download.scm index fa94fad8f8..6cf267d6c8 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -60,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 @@ -74,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 @@ -93,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 diff --git a/guix/git.scm b/guix/git.scm index d007916662..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 (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,7 +36,12 @@ #: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 (string-append (cache-directory #:ensure? #f) @@ -154,6 +162,7 @@ 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 . "master"))) @@ -164,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 @@ -177,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/grafts.scm b/guix/grafts.scm index f303e925f1..db9c6854fd 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,13 @@ are not recursively applied to dependencies of DRV." ,@(append (map add-label sources) (map add-label targets))) #:outputs outputs - #:local-build? #t))))) + + ;; Grafts are computationally cheap so no + ;; need to offload or substitute. + #:local-build? #t + #:substitutable? #f + + #: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 +339,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/import/cran.scm b/guix/import/cran.scm index 89c84f7037..8f2c10258a 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -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/hackage.scm b/guix/import/hackage.scm index 766a0b53f1..48db764b3c 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -215,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/inferior.scm b/guix/inferior.scm index 1dbb9e1699..ccc1c27cb2 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -56,6 +56,7 @@ open-inferior close-inferior inferior-eval + inferior-eval-with-store inferior-object? inferior-packages @@ -402,55 +403,70 @@ input/output ports.)" (unless (port-closed? client) (loop)))))) -(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." - ;; Create a named socket in /tmp and let the inferior of PACKAGE 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. +(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)) - (inferior (inferior-package-inferior package)) (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 ((socket (socket AF_UNIX SOCK_STREAM 0))) + `(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))) - (package (hashv-ref %package-table - ,(inferior-package-id package))) - (drv ,(if target - `(package-cross-derivation store package - ,target - ,system) - `(package-derivation store package - ,system)))) - (close-connection store) - (close-port socket) - (derivation-file-name drv))) + (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-derivation-from-file (read-inferior-response inferior)))))) + (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)) diff --git a/guix/nar.scm b/guix/nar.scm index 0495b4a40c..8894f10d2b 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -22,8 +22,12 @@ #: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 (gcrypt hash) #:use-module (guix pki) @@ -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/profiles.scm b/guix/profiles.scm index 89e92ea2ba..ba4446bc2f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -56,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 diff --git a/guix/progress.scm b/guix/progress.scm index 9da667a027..65080bcf24 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -197,7 +198,7 @@ throughput." (define elapsed (duration->seconds (time-difference (current-time time-monotonic) start-time))) - (if (number? size) + (if (and (number? size) (not (zero? size))) (let* ((% (* 100.0 (/ transferred size))) (throughput (/ transferred elapsed)) (left (format #f " ~a ~a" file @@ -211,17 +212,20 @@ throughput." (current-terminal-columns)) log-port) (force-output log-port)) - (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)))) + ;; 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. diff --git a/guix/scripts.scm b/guix/scripts.scm index 98751bc812..5e20ecd92c 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -27,6 +27,7 @@ #: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) @@ -37,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: ;;; @@ -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/build.scm b/guix/scripts/build.scm index 13978abb77..0b7da3189e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,8 @@ #: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)) @@ -63,7 +65,7 @@ (define %default-log-urls ;; Default base URLs for build logs. - '("http://hydra.gnu.org/log")) + '("http://ci.guix.info/log")) ;; XXX: The following procedure cannot be in (guix store) because of the ;; dependency on (guix derivations). @@ -270,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 @@ -277,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. @@ -291,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_ " @@ -302,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) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index e59502076c..7d0ecb0a4d 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,6 @@ ;;; 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. ;;; @@ -18,11 +19,13 @@ (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) @@ -38,9 +41,13 @@ ;; Specifications of the command-line options. (list (option '(#\f "format") #t #f (lambda (opt name arg result) - (unless (member arg '("human" "channels")) + (unless (member arg '("human" "channels" "json" "recutils")) (leave (G_ "~a: unsupported output format~%") arg)) - (alist-cons 'format 'channels result))) + (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) @@ -58,6 +65,8 @@ 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")) @@ -78,6 +87,22 @@ Display information about the channels currently in use.\n")) (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 @@ -98,10 +123,19 @@ within a Git checkout." (format #t (G_ " branch: ~a~%") (reference-shorthand head)) (format #t (G_ " commit: ~a~%") commit)) ('channels - (pretty-print `(list (channel - (name 'guix) - (url ,(dirname directory)) - (commit ,commit)))))) + (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) @@ -110,34 +144,46 @@ 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 (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. - (_ '???))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest - (if (zero? number) - profile - (generation-file-name profile number)))))))))) + (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)) @@ -146,15 +192,16 @@ in the format specified by FMT." ;;; (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))) + (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 (current-profile) + (match profile (#f (display-checkout-info format)) (profile diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 2bd2ac4a06..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. ;;; @@ -44,7 +45,7 @@ `((format . ,bytevector->nix-base32-string))) (define (show-help) - (display (G_ "Usage: gcrypt hash [OPTION] FILE + (display (G_ "Usage: guix hash [OPTION] FILE Return the cryptographic hash of FILE. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' @@ -93,7 +94,7 @@ and 'hexadecimal' can be used as well).\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "gcrypt hash"))))) + (show-version-and-exit "guix hash"))))) 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 13aa8923cd..6c6680ab58 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. ;;; @@ -38,7 +39,7 @@ #: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) @@ -52,6 +53,9 @@ #:export (compressor? lookup-compressor self-contained-tarball + docker-image + squashfs-image + guix-pack)) ;; Type of a compression tool. @@ -103,8 +107,50 @@ found." (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? @@ -117,125 +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)) - ,@(source-module-closure - `((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-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" - #+@(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)))))))))) + (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)) @@ -244,7 +282,7 @@ added to the pack." (define* (squashfs-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -255,75 +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 build - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - '((guix build utils) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-sqlite3&co - #~(begin - (use-modules (guix build utils) - (gnu build install) - (guix build store-copy) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (define database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) - (setenv "PATH" (string-append #$archiver "/bin")) + (define build + (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) @@ -333,7 +381,7 @@ added to the pack." (define* (docker-image name profile #:key target - deduplicate? + (profile-name "guix-profile") (compressor (first %compressors)) localstatedir? (symlinks '()) @@ -343,6 +391,11 @@ 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 database + (and localstatedir? + (file-append (store-database (list profile)) + "/db/db.sqlite"))) + (define defmod 'define-module) ;trick Geiser (define build @@ -361,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) @@ -538,6 +592,7 @@ 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) @@ -555,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 @@ -571,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))) @@ -609,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))) @@ -626,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")) @@ -642,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_ " @@ -730,7 +813,8 @@ Create a bundle of PACKAGE.\n")) (#f (leave (G_ "~a: unknown pack format~%") pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (profile-name (assoc-ref opts 'profile-name))) (run-with-store store (mlet* %store-monad ((profile (profile-derivation manifest @@ -749,6 +833,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? + #:profile-name + profile-name #:archiver archiver))) (mbegin %store-monad diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5d146b8427..5743816324 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -164,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)))))) ;;; @@ -769,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) 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/pull.scm b/guix/scripts/pull.scm index 188237aa90..dc83729911 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -87,6 +87,8 @@ Download and deploy the latest version of Guix.\n")) (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) @@ -164,15 +166,18 @@ Download and deploy the latest version of Guix.\n")) (_ #t))) (define* (build-and-install instances profile - #:key verbose?) - "Build the tool from SOURCE, and install it in 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)) (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad - (update-profile profile manifest) - (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." @@ -497,8 +502,6 @@ Use '~/.config/guix/channels.scm' instead.")) (ensure-default-profile) (cond ((assoc-ref opts 'query) (process-query opts profile)) - ((assoc-ref opts 'dry-run?) - #t) ;XXX: not very useful (else (with-store store (with-status-report print-build-event @@ -531,6 +534,8 @@ Use '~/.config/guix/channels.scm' instead.")) (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?)))))))))))))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 58fc64db1f..1d86f949c8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -179,24 +179,24 @@ specified with `--select'.\n")) (let* ((packages (fold-packages cons '())) (total (length packages))) - (define covered - (fold (lambda (updater covered) - (let ((matches (count (upstream-updater-predicate updater) - packages))) + (define uncovered + (fold (lambda (updater uncovered) + (let ((matches (filter (upstream-updater-predicate updater) + packages))) ;; TRANSLATORS: The parenthetical expression here is rendered ;; like "(42% coverage)" and denotes the fraction of packages ;; covered by the given updater. (format #t (G_ " - ~a: ~a (~2,1f% coverage)~%") (upstream-updater-name updater) (G_ (upstream-updater-description updater)) - (* 100. (/ matches total))) - (+ covered matches))) - 0 + (* 100. (/ (length matches) total))) + (lset-difference eq? uncovered matches))) + packages (force %updaters))) (newline) (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%") - (* 100. (/ covered total)))) + (* 100. (/ (- total (length uncovered)) total)))) (exit 0)) (define (warn-no-updater package) @@ -278,7 +278,12 @@ the latest known version of ~a (~a)~%") (define (all-packages) "Return the list of all the distro's packages." - (fold-packages cons '() + (fold-packages (lambda (package result) + ;; Ignore deprecated packages. + (if (package-superseded package) + result + (cons package result))) + '() #:select? (const #t))) ;include hidden packages (define (list-dependents packages) 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/size.scm b/guix/scripts/size.scm index 344be40883..25218a2945 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -297,7 +297,7 @@ Report the size of PACKAGE and its dependencies.\n")) (leave (G_ "missing store item argument\n"))) ((files ..1) (leave-on-EPIPE - ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted + ;; Turn off grafts because (1) substitute servers do not serve grafted ;; packages, and (2) they do not make any difference on the ;; resulting size. (parameterize ((%graft? #f)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index eb82224016..d6dc9b6448 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1052,7 +1052,7 @@ found." (#f ;; This can only happen when this script is not invoked by the ;; daemon. - '("http://hydra.gnu.org")))) + '("http://ci.guix.info")))) (define substitute-urls ;; List of substitute URLs. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f9af38b7c5..8eb32c62bc 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -175,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")) @@ -235,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)))))) ;;; @@ -486,9 +497,10 @@ STORE is an open connection to the store." (old-entries (map boot-parameters->menu-entry old-params))) (run-with-store store (mlet* %store-monad - ((bootcfg ((bootloader-configuration-file-generator bootloader) - bootloader-config entries - #:old-entries old-entries)) + ((bootcfg (lower-object + ((bootloader-configuration-file-generator bootloader) + bootloader-config entries + #:old-entries old-entries))) (bootcfg-file -> (bootloader-configuration-file bootloader)) (target -> "/") (drvs -> (list bootcfg))) @@ -783,19 +795,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? @@ -823,6 +834,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)) @@ -842,39 +872,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)) @@ -883,7 +890,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) @@ -892,7 +899,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 "/")))) @@ -904,7 +911,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. @@ -1161,7 +1168,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 diff --git a/guix/self.scm b/guix/self.scm index 3e29c9a42a..f2db3dbf52 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -206,21 +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* (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)) @@ -238,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/" @@ -272,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)) @@ -290,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 @@ -335,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'. @@ -404,11 +413,32 @@ 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")) + ("share/guix/ci.guix.info.pub" ;alias + ,(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 @@ -422,6 +452,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")) @@ -441,6 +472,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/" @@ -666,6 +701,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 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 index ffa9d9e93c..868bfdca21 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -325,7 +325,19 @@ addition to build events." (display "\r" port)) ;erase the spinner (match event (('build-started drv . _) - (format port (info (G_ "building ~a...")) 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?))) @@ -393,6 +405,9 @@ addition to build events." 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) diff --git a/guix/store.scm b/guix/store.scm index b1bdbf3813..509fd4def6 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -23,6 +23,7 @@ #: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 (gcrypt hash) @@ -30,6 +31,7 @@ #: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) @@ -55,6 +57,7 @@ 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? @@ -332,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) @@ -348,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) @@ -523,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))))))))) @@ -543,7 +546,8 @@ 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." @@ -689,7 +693,7 @@ encoding conversion errors." (map (if (false-if-exception (resolve-interface '(gnutls))) (cut string-append "https://" <>) (cut string-append "http://" <>)) - '("mirror.hydra.gnu.org"))) + '("ci.guix.info"))) (define* (set-build-options server #:key keep-failed? keep-going? fallback? @@ -1486,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 diff --git a/guix/store/database.scm b/guix/store/database.scm index 341276bc30..e6bfbe763e 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -36,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 @@ -51,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)) @@ -85,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." diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 53810c680f..21b0c81f3d 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -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 bcf9b990e5..f4948148c4 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -27,6 +27,7 @@ #: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) @@ -35,10 +36,13 @@ 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 @@ -147,6 +151,14 @@ too expensive to build entirely in the test store." (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))) @@ -161,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 96f403acf5..60636edac0 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -816,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))) @@ -865,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))) @@ -898,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~%~}~;~]" @@ -918,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) |