diff options
Diffstat (limited to 'guix')
40 files changed, 2068 insertions, 383 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm new file mode 100644 index 0000000000..3582f0e328 --- /dev/null +++ b/guix/build-system/cargo.scm @@ -0,0 +1,149 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> +;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; +;;; 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 cargo) + #:use-module (guix search-paths) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (cargo-build-system + crate-url + crate-url? + crate-uri)) + +(define crate-url "https://crates.io/api/v1/crates/") +(define crate-url? (cut string-prefix? crate-url <>)) + +(define (crate-uri name version) + "Return a URI string for the crate package hosted at crates.io corresponding +to NAME and VERSION." + (string-append crate-url name "/" version "/download")) + +(define (default-cargo) + "Return the default Cargo package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((rust (resolve-interface '(gnu packages rust)))) + (module-ref rust 'cargo))) + +(define (default-rustc) + "Return the default Rustc package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((rust (resolve-interface '(gnu packages rust)))) + (module-ref rust 'rustc))) + +(define %cargo-build-system-modules + ;; Build-side modules imported by default. + `((guix build cargo-build-system) + ,@%gnu-build-system-modules)) + +(define* (cargo-build store name inputs + #:key + (tests? #t) + (test-target #f) + (configure-flags #f) + (phases '(@ (guix build cargo-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %cargo-build-system-modules) + (modules '((guix build cargo-build-system) + (guix build utils)))) + "Build SOURCE using CARGO, and with INPUTS." + + (define builder + `(begin + (use-modules ,@modules) + (cargo-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:test-target ,test-target + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs (cons "src" outputs) + #:guile-for-build guile-for-build)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (cargo (default-cargo)) + (rustc (default-rustc)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + + (define private-keywords + '(#:source #:target #:cargo #:rustc #:inputs #:native-inputs #:outputs)) + + (and (not target) ;; TODO: support cross-compilation + (bag + (name name) + (system system) + (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system' + ,@(standard-packages))) + (build-inputs `(("cargo" ,cargo) + ("rustc" ,rustc) + ,@native-inputs)) + (outputs outputs) + (build cargo-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define cargo-build-system + (build-system + (name 'cargo) + (description + "Cargo build system, to build Rust crates") + (lower lower))) diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm new file mode 100644 index 0000000000..f4f57b5ad5 --- /dev/null +++ b/guix/build-system/ocaml.scm @@ -0,0 +1,181 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017 Julien Lepiller <julien@lepiller.eu> +;;; +;;; 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 ocaml) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (%ocaml-build-system-modules + ocaml-build + ocaml-build-system)) + +;; Commentary: +;; +;; Standard build procedure for packages using ocaml. This is implemented as an +;; extension of `gnu-build-system'. +;; +;; OCaml packages don't use a single standard for their build system. Some use +;; autotools, other use custom configure scripts with Makefiles, others use +;; oasis to generate the configure script and Makefile and lastly, some use +;; custom ocaml scripts. +;; +;; Each phase in the build system will try to figure out what the build system +;; is for that package. Most packages come with a custom configure script and +;; a Makefile that in turn call custom build tools. Packages built with oasis +;; will have a `setup.ml' file in the top directory, that can be used for all +;; phases. In that case the Makefile is here only to call that script. In case +;; the setup.ml do not work as expected, the @var{use-make} argument can be +;; used to ignore the setup.ml file and run make instead. +;; +;; Some packages use their own custom scripts, `pkg/pkg.ml' or +;; `pkg/build.ml'. They can be used here too. +;; +;; Code: + +(define %ocaml-build-system-modules + ;; Build-side modules imported by default. + `((guix build ocaml-build-system) + ,@%gnu-build-system-modules)) + +(define (default-ocaml) + "Return the default OCaml package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml))) + +(define (default-findlib) + "Return the default OCaml-findlib package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml-findlib))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (ocaml (default-ocaml)) + (findlib (default-findlib)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:ocaml #:findlib #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("ocaml" ,ocaml) + ("findlib" ,findlib) + ,@native-inputs)) + (outputs outputs) + (build ocaml-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (ocaml-build store name inputs + #:key (guile #f) + (outputs '("out")) (configure-flags ''()) + (search-paths '()) + (make-flags ''()) + (build-flags ''()) + (out-of-source? #t) + (use-make? #f) + (tests? #t) + (test-flags ''("--enable-tests")) + (test-target "test") + (install-target "install") + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build ocaml-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules %ocaml-build-system-modules) + (modules '((guix build ocaml-build-system) + (guix build utils)))) + "Build SOURCE using OCAML, and with INPUTS. This assumes that SOURCE +provides a 'setup.ml' file as its build system." + (define builder + `(begin + (use-modules ,@modules) + (ocaml-build #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases ,phases + #:configure-flags ,configure-flags + #:test-flags ,test-flags + #:make-flags ,make-flags + #:build-flags ,build-flags + #:out-of-source? ,out-of-source? + #:use-make? ,use-make? + #:tests? ,tests? + #:test-target ,test-target + #:install-target ,install-target + #:validate-runpath? ,validate-runpath? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define ocaml-build-system + (build-system + (name 'ocaml) + (description "The standard OCaml build system") + (lower lower))) + +;;; ocaml.scm ends here diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm new file mode 100644 index 0000000000..7d656a8d58 --- /dev/null +++ b/guix/build/cargo-build-system.scm @@ -0,0 +1,110 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; +;;; 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 cargo-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + cargo-build)) + +;; Commentary: +;; +;; Builder-side code of the standard Rust package build procedure. +;; +;; Code: + +;; FIXME: Needs to be parsed from url not package name. +(define (package-name->crate-name name) + "Return the crate name of NAME." + (match (string-split name #\-) + (("rust" rest ...) + (string-join rest "-")) + (_ #f))) + +(define* (configure #:key inputs #:allow-other-keys) + "Replace Cargo.toml [dependencies] section with guix inputs." + ;; Make sure Cargo.toml is writeable when the crate uses git-fetch. + (chmod "Cargo.toml" #o644) + (let ((port (open-file "Cargo.toml" "a" #:encoding "utf-8"))) + (format port "~%[replace]~%") + (for-each + (match-lambda + ((name . path) + (let ((crate (package-name->crate-name name))) + (when (and crate path) + (match (string-split (basename path) #\-) + ((_ ... version) + (format port "\"~a:~a\" = { path = \"~a/share/rust-source\" }~%" + crate version path))))))) + inputs) + (close-port port)) + #t) + +(define* (build #:key (cargo-build-flags '("--release" "--frozen")) + #:allow-other-keys) + "Build a given Cargo package." + (if (file-exists? "Cargo.lock") + (zero? (apply system* `("cargo" "build" ,@cargo-build-flags))) + #t)) + +(define* (check #:key tests? #:allow-other-keys) + "Run tests for a given Cargo package." + (if (and tests? (file-exists? "Cargo.lock")) + (zero? (system* "cargo" "test")) + #t)) + +(define* (install #:key inputs outputs #:allow-other-keys) + "Install a given Cargo package." + (let* ((out (assoc-ref outputs "out")) + (src (assoc-ref inputs "source")) + (rsrc (string-append (assoc-ref outputs "src") + "/share/rust-source"))) + (mkdir-p rsrc) + ;; Rust doesn't have a stable ABI yet. Because of this + ;; Cargo doesn't have a search path for binaries yet. + ;; Until this changes we are working around this by + ;; distributing crates as source and replacing + ;; references in Cargo.toml with store paths. + (copy-recursively "src" (string-append rsrc "/src")) + (install-file "Cargo.toml" rsrc) + ;; When the package includes executables we install + ;; it using cargo install. This fails when the crate + ;; doesn't contain an executable. + (if (file-exists? "Cargo.lock") + (system* "cargo" "install" "--root" out) + (mkdir out)))) + +(define %standard-phases + ;; 'configure' phase is not needed. + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + +(define* (cargo-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Cargo package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; cargo-build-system.scm ends here diff --git a/guix/build/download.scm b/guix/build/download.scm index 8e32b3d7ff..203338b527 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -289,9 +289,12 @@ DIRECTORY. Those authority certificates are checked when (string-suffix? ".pem" file))) '()))) (for-each (lambda (file) - (set-certificate-credentials-x509-trust-file! - cred (string-append directory "/" file) - x509-certificate-format/pem)) + (let ((file (string-append directory "/" file))) + ;; Protect against dangling symlinks. + (when (file-exists? file) + (set-certificate-credentials-x509-trust-file! + cred file + x509-certificate-format/pem)))) (or files '())) cred)) diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index bc4c0e3d5f..21c78cc8f5 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> +;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -64,7 +64,8 @@ when producing a bootstrap libc." #t)) (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ -util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|libc(rt|)_nonshared\\.a)$") +util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ +_nonshared\\.a)$") (setvbuf (current-output-port) _IOLBF) (let* ((libdir (string-append output "/lib"))) diff --git a/guix/build/ocaml-build-system.scm b/guix/build/ocaml-build-system.scm new file mode 100644 index 0000000000..f77251ca09 --- /dev/null +++ b/guix/build/ocaml-build-system.scm @@ -0,0 +1,119 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017 Julien Lepiller <julien@lepiller.eu> +;;; +;;; 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 ocaml-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:export (%standard-phases + ocaml-build)) + +;; Commentary: +;; +;; Builder-side code of the standard ocaml build procedure. +;; +;; Code: + +(define* (ocaml-findlib-environment #:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out"))) + (setenv "OCAMLFIND_DESTDIR" (string-append out "/lib/ocaml/site-lib")) + (setenv "OCAMLFIND_LDCONF" "ignore")) + #t) + +(define* (configure #:key outputs (configure-flags '()) + (test-flags '("--enable-tests")) tests? + #:allow-other-keys) + "Configure the given package." + (let* ((out (assoc-ref outputs "out"))) + (format #t "build directory: ~s~%" (getcwd)) + (if (file-exists? "setup.ml") + (let ((args `("-configure" + "--prefix" ,out + ,@(if tests? + test-flags + '()) + ,@configure-flags))) + (format #t "running 'setup.ml' with arguments ~s~%" args) + (zero? (apply system* "ocaml" "setup.ml" args))) + (let ((args `("-prefix" ,out ,@configure-flags))) + (format #t "running 'configure' with arguments ~s~%" args) + (zero? (apply system* "./configure" args)))))) + +(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)) + (if (file-exists? "Makefile") + (zero? (apply system* "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)))))) + +(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))) + (if (file-exists? "Makefile") + (zero? (apply system* "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))))))) + +(define* (install #:key outputs (build-flags '()) (make-flags '()) (use-make? #f) + (install-target "install") + #:allow-other-keys) + "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)) + (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"))))))) + +(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"))) + +(define %standard-phases + ;; Everything is as with the GNU Build System except for the `configure' + ;; , `build', `check' and `install' phases. + (modify-phases gnu:%standard-phases + (add-before 'configure 'ocaml-findlib-environment + ocaml-findlib-environment) + (add-before 'install 'prepare-install prepare-install) + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + +(define* (ocaml-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; ocaml-build-system.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 9386c0f5d0..2e37846ff0 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; @@ -1474,7 +1474,9 @@ always a positive integer." ;; ENOTTY is what we're after but 2012-and-earlier Linux versions ;; would return EINVAL instead in some cases: ;; <https://bugs.ruby-lang.org/issues/10494>. - (if (or (= errno ENOTTY) (= errno EINVAL)) + ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for + ;; that ioctl. + (if (memv errno (list ENOTTY EINVAL ENOSYS)) (fall-back) (apply throw args)))))) diff --git a/guix/derivations.scm b/guix/derivations.scm index 7ed9bd61d3..b712c508e5 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -120,7 +121,7 @@ ;;; Nix derivations, as implemented in Nix's `derivations.cc'. ;;; -(define-record-type <derivation> +(define-immutable-record-type <derivation> (make-derivation outputs inputs sources system builder args env-vars file-name) derivation? @@ -453,19 +454,22 @@ one-argument procedure similar to that returned by 'substitution-oracle'." (loop (read drv-port) (cons (ununquote exp) result)))))) -(define read-derivation - (let ((cache (make-weak-value-hash-table 200))) - (lambda (drv-port) - "Read the derivation from DRV-PORT and return the corresponding +(define %derivation-cache + ;; Maps derivation file names to <derivation> objects. + ;; XXX: This is redundant with 'atts-cache' in the store. + (make-weak-value-hash-table 200)) + +(define (read-derivation drv-port) + "Read the derivation from DRV-PORT and return the corresponding <derivation> object." - ;; Memoize that operation because `%read-derivation' is quite expensive, - ;; and because the same argument is read more than 15 times on average - ;; during something like (package-derivation s gdb). - (let ((file (and=> (port-filename drv-port) basename))) - (or (and file (hash-ref cache file)) - (let ((drv (%read-derivation drv-port))) - (hash-set! cache file drv) - drv)))))) + ;; Memoize that operation because `%read-derivation' is quite expensive, + ;; and because the same argument is read more than 15 times on average + ;; during something like (package-derivation s gdb). + (let ((file (port-filename drv-port))) + (or (and file (hash-ref %derivation-cache file)) + (let ((drv (%read-derivation drv-port))) + (hash-set! %derivation-cache file drv) + drv)))) (define-inlinable (write-sequence lst write-item port) ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a @@ -520,9 +524,9 @@ that form." (define (write-input input port) (match input (($ <derivation-input> path sub-drvs) - (display "(" port) - (write path port) - (display "," port) + (display "(\"" port) + (display path port) + (display "\"," port) (write-string-list sub-drvs) (display ")" port)))) @@ -545,7 +549,7 @@ that form." (write-list inputs write-input port) (display "," port) (write-string-list sources) - (format port ",~s,~s," system builder) + (simple-format port ",\"~a\",\"~a\"," system builder) (write-string-list args) (display "," port) (write-list env-vars write-env-var port) @@ -814,14 +818,6 @@ output should not be used." e outputs))) - (define (set-file-name drv file) - ;; Set FILE as the 'file-name' field of DRV. - (match drv - (($ <derivation> outputs inputs sources system builder - args env-vars) - (make-derivation outputs inputs sources system builder - args env-vars file)))) - (define input->derivation-input (match-lambda (((? derivation? drv)) @@ -866,10 +862,12 @@ output should not be used." system builder args env-vars #f)) (drv (add-output-paths drv-masked))) - (let ((file (add-text-to-store store (string-append name ".drv") - (derivation->string drv) - (map derivation-input-path inputs)))) - (set-file-name drv file)))) + (let* ((file (add-text-to-store store (string-append name ".drv") + (derivation->string drv) + (map derivation-input-path inputs))) + (drv* (set-field drv (derivation-file-name) file))) + (hash-set! %derivation-cache file drv*) + drv*))) (define* (map-derivation store drv mapping #:key (system (%current-system))) diff --git a/guix/docker.scm b/guix/docker.scm new file mode 100644 index 0000000000..dbe1e5351c --- /dev/null +++ b/guix/docker.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 docker) + #:use-module (guix hash) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module ((guix build utils) + #:select (delete-file-recursively + with-directory-excursion)) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:export (build-docker-image)) + +;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image +;; containing the closure at PATH. +(define docker-id + (compose bytevector->base16-string sha256 string->utf8)) + +(define (layer-diff-id layer) + "Generate a layer DiffID for the given LAYER archive." + (string-append "sha256:" (bytevector->base16-string (file-sha256 layer)))) + +;; This is the semantic version of the JSON metadata schema according to +;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md +;; It is NOT the version of the image specification. +(define schema-version "1.0") + +(define (image-description id time) + "Generate a simple image description." + `((id . ,id) + (created . ,time) + (container_config . #nil))) + +(define (generate-tag path) + "Generate an image tag for the given PATH." + (match (string-split (basename path) #\-) + ((hash name . rest) (string-append name ":" hash)))) + +(define (manifest path id) + "Generate a simple image manifest." + `(((Config . "config.json") + (RepoTags . (,(generate-tag path))) + (Layers . (,(string-append id "/layer.tar")))))) + +;; According to the specifications this is required for backwards +;; compatibility. It duplicates information provided by the manifest. +(define (repositories path id) + "Generate a repositories file referencing PATH and the image ID." + `((,(generate-tag path) . ((latest . ,id))))) + +;; See https://github.com/opencontainers/image-spec/blob/master/config.md +(define (config layer time arch) + "Generate a minimal image configuration for the given LAYER file." + ;; "architecture" must be values matching "platform.arch" in the + ;; runtime-spec at + ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform + `((architecture . ,arch) + (comment . "Generated by GNU Guix") + (created . ,time) + (config . #nil) + (container_config . #nil) + (os . "linux") + (rootfs . ((type . "layers") + (diff_ids . (,(layer-diff-id layer))))))) + +(define* (build-docker-image path #:key system) + "Generate a Docker image archive from the given store PATH. The image +contains the closure of the given store item." + (let ((id (docker-id path)) + (time (strftime "%FT%TZ" (localtime (current-time)))) + (name (string-append (getcwd) + "/docker-image-" (basename path) ".tar")) + (arch (match system + ("x86_64-linux" "amd64") + ("i686-linux" "386") + ("armhf-linux" "arm") + ("mips64el-linux" "mips64le")))) + (and (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + ;; Add symlink from /bin to /gnu/store/.../bin + (symlink (string-append path "/bin") "bin") + + (mkdir id) + (with-directory-excursion id + (with-output-to-file "VERSION" + (lambda () (display schema-version))) + (with-output-to-file "json" + (lambda () (scm->json (image-description id time)))) + + ;; Wrap it up + (let ((items (with-store store + (requisites store (list path))))) + (and (zero? (apply system* "tar" "-cf" "layer.tar" + (cons "../bin" items))) + (delete-file "../bin")))) + + (with-output-to-file "config.json" + (lambda () + (scm->json (config (string-append id "/layer.tar") + time arch)))) + (with-output-to-file "manifest.json" + (lambda () + (scm->json (manifest path id)))) + (with-output-to-file "repositories" + (lambda () + (scm->json (repositories path id))))) + (and (zero? (system* "tar" "-C" directory "-cf" name ".")) + (begin (delete-file-recursively directory) #t)))) + name))) diff --git a/guix/gexp.scm b/guix/gexp.scm index fd5dc49233..1f7fbef0a0 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -669,41 +669,34 @@ references; otherwise, return only non-native references." result) result)) (($ <gexp-input> (? gexp? exp) _ #f) - (if native? - (append (gexp-inputs exp #:native? #t) - result) - (append (gexp-inputs exp) - result))) + (append (gexp-inputs exp #:native? native?) + result)) (($ <gexp-input> (? string? str)) (if (direct-store-path? str) (cons `(,str) result) result)) - (($ <gexp-input> (? struct? thing) output) - (if (lookup-compiler thing) + (($ <gexp-input> (? struct? thing) output n?) + (if (and (eqv? n? native?) (lookup-compiler thing)) ;; THING is a derivation, or a package, or an origin, etc. (cons `(,thing ,output) result) result)) (($ <gexp-input> (lst ...) output n?) - (fold-right add-reference-inputs result - ;; XXX: For now, automatically convert LST to a list of - ;; gexp-inputs. - (map (match-lambda - ((? gexp-input? x) x) - (x (%gexp-input x "out" (or n? native?)))) - lst))) + (if (eqv? native? n?) + (fold-right add-reference-inputs result + ;; XXX: For now, automatically convert LST to a list of + ;; gexp-inputs. + (map (match-lambda + ((? gexp-input? x) x) + (x (%gexp-input x "out" (or n? native?)))) + lst)) + result)) (_ ;; Ignore references to other kinds of objects. result))) - (define (native-input? x) - (and (gexp-input? x) - (gexp-input-native? x))) - (fold-right add-reference-inputs '() - (if native? - (filter native-input? (gexp-references exp)) - (remove native-input? (gexp-references exp))))) + (gexp-references exp))) (define gexp-native-inputs (cut gexp-inputs <> #:native? #t)) @@ -819,9 +812,9 @@ environment." (cons exp result)) ((ungexp-native-splicing _ ...) (cons exp result)) - ((exp0 exp ...) + ((exp0 . exp) (let ((result (loop #'exp0 result))) - (fold loop result #'(exp ...)))) + (loop #'exp result))) (_ result)))) @@ -853,9 +846,9 @@ environment." (match (assoc exp substs) ((_ id) id) - (_ - #'(syntax-error "error: no 'ungexp' substitution" - #'ref)))) + (_ ;internal error + (with-syntax ((exp exp)) + #'(syntax-error "error: no 'ungexp' substitution" exp))))) (define (substitute-ungexp-splicing exp substs) (syntax-case exp () @@ -867,7 +860,7 @@ environment." #,(substitute-references #'(rest ...) substs)))) (_ #'(syntax-error "error: no 'ungexp-splicing' substitution" - #'ref)))))) + exp)))))) (define (substitute-references exp substs) ;; Return a variant of EXP where all the cars of SUBSTS have been @@ -882,9 +875,9 @@ environment." (substitute-ungexp-splicing exp substs)) (((ungexp-native-splicing _ ...) rest ...) (substitute-ungexp-splicing exp substs)) - ((exp0 exp ...) + ((exp0 . exp) #`(cons #,(substitute-references #'exp0 substs) - #,(substitute-references #'(exp ...) substs))) + #,(substitute-references #'exp substs))) (x #''x))) (syntax-case s (ungexp output) diff --git a/guix/git-download.scm b/guix/git-download.scm index 9cc6dd3d94..62e625c715 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -30,7 +30,9 @@ git-reference-commit git-reference-recursive? - git-fetch)) + git-fetch + git-version + git-file-name)) ;;; Commentary: ;;; @@ -82,20 +84,39 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (((names dirs) ...) dirs))) - (git-fetch '#$(git-reference-url ref) - '#$(git-reference-commit ref) + (git-fetch (getenv "git url") (getenv "git commit") #$output - #:recursive? '#$(git-reference-recursive? ref) + #:recursive? (call-with-input-string + (getenv "git recursive?") + read) #:git-command (string-append #+git "/bin/git"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build + + ;; Use environment variables and a fixed script name so + ;; there's only one script in store for all the + ;; downloads. + #:script-name "git-download" + #:env-vars + `(("git url" . ,(git-reference-url ref)) + ("git commit" . ,(git-reference-commit ref)) + ("git recursive?" . ,(object->string + (git-reference-recursive? ref)))) + #:system system #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo #:hash hash #:recursive? #t - #:guile-for-build guile - #:local-build? #t))) + #:guile-for-build guile))) + +(define (git-version version revision commit) + "Return the version string for packages using git-download." + (string-append version "-" revision "." (string-take commit 7))) + +(define (git-file-name name version) + "Return the file-name for packages using git-download." + (string-append name "-" version "-checkout")) ;;; git-download.scm ends here diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 4d4bb452be..789724c8c0 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -76,17 +76,17 @@ ;;; (define %gnumaint-base-url - "http://cvs.savannah.gnu.org/viewvc/*checkout*/gnumaint/") + "http://cvs.savannah.gnu.org/viewvc/*checkout*/womb/gnumaint/") (define %package-list-url (string->uri - (string-append %gnumaint-base-url "gnupackages.txt?root=womb"))) + (string-append %gnumaint-base-url "gnupackages.txt"))) (define %package-description-url ;; This file contains package descriptions in recutils format. ;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>. (string->uri - (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb"))) + (string-append %gnumaint-base-url "pkgblurbs.txt"))) (define-record-type* <gnu-package-descriptor> gnu-package-descriptor diff --git a/guix/grafts.scm b/guix/grafts.scm index dda7c1d235..2006d3908e 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -214,6 +214,17 @@ available." (delete-duplicates (concatenate refs) string=?)) result)))))) +(define-syntax-rule (with-cache key exp ...) + "Cache the value of monadic expression EXP under KEY." + (mlet %state-monad ((cache (current-state))) + (match (vhash-assq key cache) + ((_ . result) ;cache hit + (return result)) + (#f ;cache miss + (mlet %state-monad ((result (begin exp ...))) + (set-current-state (vhash-consq key result cache)) + (return result)))))) + (define* (cumulative-grafts store drv grafts references #:key @@ -252,48 +263,39 @@ derivations to the corresponding set of grafts." #:system system)) (state-return grafts)))) - (define (return/cache cache value) - (mbegin %state-monad - (set-current-state (vhash-consq drv value cache)) - (return value))) - - (mlet %state-monad ((cache (current-state))) - (match (vhash-assq drv cache) - ((_ . grafts) ;hit + (with-cache drv + (match (non-self-references references drv outputs) + (() ;no dependencies (return grafts)) - (#f ;miss - (match (non-self-references references drv outputs) - (() ;no dependencies - (return/cache cache grafts)) - (deps ;one or more dependencies - (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))) - (let ((grafts (delete-duplicates (concatenate grafts) equal?))) - (match (filter (lambda (graft) - (member (graft-origin-file-name graft) deps)) - grafts) - (() - (return/cache cache grafts)) - ((applicable ..1) - ;; Use APPLICABLE, the subset of GRAFTS that is really - ;; applicable to DRV, to avoid creating several identical - ;; grafted variants of DRV. - (let* ((new (graft-derivation/shallow store drv applicable - #:guile guile - #:system system)) - - ;; Replace references to any of the outputs of DRV, - ;; even if that's more than needed. This is so that - ;; the result refers only to the outputs of NEW and - ;; not to those of DRV. - (grafts (append (map (lambda (output) - (graft - (origin drv) - (origin-output output) - (replacement new) - (replacement-output output))) - (derivation-output-names drv)) - grafts))) - (return/cache cache grafts)))))))))))) + (deps ;one or more dependencies + (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps))) + (let ((grafts (delete-duplicates (concatenate grafts) equal?))) + (match (filter (lambda (graft) + (member (graft-origin-file-name graft) deps)) + grafts) + (() + (return grafts)) + ((applicable ..1) + ;; Use APPLICABLE, the subset of GRAFTS that is really + ;; applicable to DRV, to avoid creating several identical + ;; grafted variants of DRV. + (let* ((new (graft-derivation/shallow store drv applicable + #:guile guile + #:system system)) + + ;; Replace references to any of the outputs of DRV, + ;; even if that's more than needed. This is so that + ;; the result refers only to the outputs of NEW and + ;; not to those of DRV. + (grafts (append (map (lambda (output) + (graft + (origin drv) + (origin-output output) + (replacement new) + (replacement-output output))) + (derivation-output-names drv)) + grafts))) + (return grafts)))))))))) (define* (graft-derivation store drv grafts #:key (guile (%guile-for-build)) @@ -333,4 +335,8 @@ it otherwise. It returns the previous setting." (lambda (store) (values (%graft? enable?) store))) +;; Local Variables: +;; eval: (put 'with-cache 'scheme-indent-function 1) +;; End: + ;;; grafts.scm ends here diff --git a/guix/graph.scm b/guix/graph.scm index 735d340c2c..7af2cd3b80 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix sets) + #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) @@ -41,9 +43,13 @@ node-transitive-edges node-reachable-count + %graph-backends + %d3js-backend %graphviz-backend graph-backend? graph-backend + graph-backend-name + graph-backend-description export-graph)) @@ -140,12 +146,14 @@ typically returned by 'node-edges' or 'node-back-edges'." ;;; (define-record-type <graph-backend> - (graph-backend prologue epilogue node edge) + (graph-backend name description prologue epilogue node edge) graph-backend? - (prologue graph-backend-prologue) - (epilogue graph-backend-epilogue) - (node graph-backend-node) - (edge graph-backend-edge)) + (name graph-backend-name) + (description graph-backend-description) + (prologue graph-backend-prologue) + (epilogue graph-backend-epilogue) + (node graph-backend-node) + (edge graph-backend-edge)) (define %colors ;; See colortbl.h in Graphviz. @@ -170,9 +178,66 @@ typically returned by 'node-edges' or 'node-back-edges'." id1 id2 (pop-color id1))) (define %graphviz-backend - (graph-backend emit-prologue emit-epilogue + (graph-backend "graphviz" + "Generate graph in DOT format for use with Graphviz." + emit-prologue emit-epilogue emit-node emit-edge)) + +;;; +;;; d3js export. +;;; + +(define (emit-d3js-prologue name port) + (format port "\ +<!DOCTYPE html> +<html> + <head> + <meta charset=\"utf-8\"> + <style> +text { + font: 10px sans-serif; + pointer-events: none; +} + </style> + <script type=\"text/javascript\" src=\"~a\"></script> + </head> + <body> + <script type=\"text/javascript\"> +var nodes = {}, + nodeArray = [], + links = []; +" (search-path %load-path "d3.v3.js"))) + +(define (emit-d3js-epilogue port) + (format port "</script><script type=\"text/javascript\" src=\"~a\"></script></body></html>" + (search-path %load-path "graph.js"))) + +(define (emit-d3js-node id label port) + (format port "\ +nodes[\"~a\"] = {\"id\": \"~a\", \"label\": \"~a\", \"index\": nodeArray.length}; +nodeArray.push(nodes[\"~a\"]);~%" + id id label id)) + +(define (emit-d3js-edge id1 id2 port) + (format port "links.push({\"source\": \"~a\", \"target\": \"~a\"});~%" + id1 id2)) + +(define %d3js-backend + (graph-backend "d3js" + "Generate chord diagrams with d3js." + emit-d3js-prologue emit-d3js-epilogue + emit-d3js-node emit-d3js-edge)) + + +;;; +;;; Shared. +;;; + +(define %graph-backends + (list %graphviz-backend + %d3js-backend)) + (define* (export-graph sinks port #:key reverse-edges? node-type @@ -181,7 +246,7 @@ typically returned by 'node-edges' or 'node-back-edges'." given BACKEND. Use NODE-TYPE to traverse the DAG. When REVERSE-EDGES? is true, draw reverse arrows." (match backend - (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge) + (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge) (emit-prologue (node-type-name node-type) port) (match node-type diff --git a/guix/http-client.scm b/guix/http-client.scm index cc3acc9587..0090783524 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -276,7 +276,12 @@ Raise an '&http-get-error' condition if downloading fails." (code code) (reason (response-reason-phrase resp))) (&message - (message "download failed")))))))))) + (message + (format + #f + (_ "~a: HTTP download failed: ~a (~s)") + (uri->string uri) code + (response-reason-phrase resp)))))))))))) ;;; diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 3fb2e213b0..463a25514e 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -23,6 +23,11 @@ #:use-module ((ice-9 rdelim) #:select (read-string)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-41) + #:use-module (ice-9 receive) + #:use-module (web uri) + #:use-module (guix combinators) #:use-module (guix http-client) #:use-module (guix hash) #:use-module (guix store) @@ -32,8 +37,10 @@ #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (gnu packages) #:export (cran->guix-package bioconductor->guix-package + recursive-import %cran-updater %bioconductor-updater)) @@ -51,19 +58,21 @@ ("Artistic-2.0" 'artistic2.0) ("Apache License 2.0" 'asl2.0) ("BSD_2_clause" 'bsd-2) + ("BSD_2_clause + file LICENSE" 'bsd-2) ("BSD_3_clause" 'bsd-3) + ("BSD_3_clause + file LICENSE" 'bsd-3) ("GPL" (list 'gpl2+ 'gpl3+)) ("GPL (>= 2)" 'gpl2+) ("GPL (>= 3)" 'gpl3+) - ("GPL-2" 'gpl2+) - ("GPL-3" 'gpl3+) - ("LGPL-2" 'lgpl2.0+) - ("LGPL-2.1" 'lgpl2.1+) - ("LGPL-3" 'lgpl3+) + ("GPL-2" 'gpl2) + ("GPL-3" 'gpl3) + ("LGPL-2" 'lgpl2.0) + ("LGPL-2.1" 'lgpl2.1) + ("LGPL-3" 'lgpl3) ("LGPL (>= 2)" 'lgpl2.0+) ("LGPL (>= 3)" 'lgpl3+) - ("MIT" 'x11) - ("MIT + file LICENSE" 'x11) + ("MIT" 'expat) + ("MIT + file LICENSE" 'expat) ((x) (string->license x)) ((lst ...) `(list ,@(map string->license lst))) (_ #f))) @@ -121,10 +130,18 @@ package definition." (define (fetch-description base-url name) "Return an alist of the contents of the DESCRIPTION file for the R package -NAME, or #f on failure. NAME is case-sensitive." +NAME, or #f in case of failure. NAME is case-sensitive." ;; This API always returns the latest release of the module. (let ((url (string-append base-url name "/DESCRIPTION"))) - (description->alist (read-string (http-fetch url))))) + (guard (c ((http-get-error? c) + (format (current-error-port) + "error: failed to retrieve package information \ +from ~s: ~a (~s)~%" + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + (description->alist (read-string (http-fetch url)))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -146,14 +163,49 @@ empty list when the FIELD cannot be found." (string-any char-set:whitespace item))) (map string-trim-both items)))))) +(define default-r-packages + (list "KernSmooth" + "MASS" + "Matrix" + "base" + "boot" + "class" + "cluster" + "codetools" + "compiler" + "datasets" + "foreign" + "grDevices" + "graphics" + "grid" + "lattice" + "methods" + "mgcv" + "nlme" + "nnet" + "parallel" + "rpart" + "spatial" + "splines" + "stats" + "stats4" + "survival" + "tcltk" + "tools" + "translations" + "utils")) + +(define (guix-name name) + "Return a Guix package name for a given R package name." + (string-append "r-" (string-map (match-lambda + (#\_ #\-) + (#\. #\-) + (chr (char-downcase chr))) + name))) + (define (description->package repository meta) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." - (define (guix-name name) - (if (string-prefix? "r-" name) - (string-downcase name) - (string-append "r-" (string-downcase name)))) - (let* ((base-url (case repository ((cran) %cran-url) ((bioconductor) %bioconductor-url))) @@ -174,42 +226,107 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (_ #f))) (tarball (with-store store (download-to-store store source-url))) (sysdepends (map string-downcase (listify meta "SystemRequirements"))) - (propagate (map guix-name (lset-union equal? - (listify meta "Imports") - (listify meta "LinkingTo") - (delete "R" - (listify meta "Depends")))))) - `(package - (name ,(guix-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (,(procedure-name uri-helper) ,name version)) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - ,@(if (not (equal? (string-append "r-" name) - (guix-name name))) - `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) - '()) - (build-system r-build-system) - ,@(maybe-inputs sysdepends) - ,@(maybe-inputs propagate 'propagated-inputs) - (home-page ,(if (string-null? home-page) - (string-append base-url name) - home-page)) - (synopsis ,synopsis) - (description ,(beautify-description (assoc-ref meta "Description"))) - (license ,license)))) - -(define* (cran->guix-package package-name #:optional (repo 'cran)) - "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' + (propagate (filter (lambda (name) + (not (member name default-r-packages))) + (lset-union equal? + (listify meta "Imports") + (listify meta "LinkingTo") + (delete "R" + (listify meta "Depends")))))) + (values + `(package + (name ,(guix-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (,(procedure-name uri-helper) ,name version)) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + ,@(if (not (equal? (string-append "r-" name) + (guix-name name))) + `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) + '()) + (build-system r-build-system) + ,@(maybe-inputs sysdepends) + ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs) + (home-page ,(if (string-null? home-page) + (string-append base-url name) + home-page)) + (synopsis ,synopsis) + (description ,(beautify-description (or (assoc-ref meta "Description") + ""))) + (license ,license)) + propagate))) + +(define cran->guix-package + (memoize + (lambda* (package-name #:optional (repo 'cran)) + "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (let* ((url (case repo - ((cran) %cran-url) - ((bioconductor) %bioconductor-svn-url))) - (module-meta (fetch-description url package-name))) - (and=> module-meta (cut description->package repo <>)))) + (let* ((url (case repo + ((cran) %cran-url) + ((bioconductor) %bioconductor-svn-url))) + (module-meta (fetch-description url package-name))) + (and=> module-meta (cut description->package repo <>)))))) + +(define* (recursive-import package-name #:optional (repo 'cran)) + "Generate a stream of package expressions for PACKAGE-NAME and all its +dependencies." + (receive (package . dependencies) + (cran->guix-package package-name repo) + (if (not package) + stream-null + + ;; Generate a lazy stream of package expressions for all unknown + ;; dependencies in the graph. + (let* ((make-state (lambda (queue done) + (cons queue done))) + (next (match-lambda + (((next . rest) . done) next))) + (imported (match-lambda + ((queue . done) done))) + (done? (match-lambda + ((queue . done) + (zero? (length queue))))) + (unknown? (lambda* (dependency #:optional (done '())) + (and (not (member dependency + done)) + (null? (find-packages-by-name + (guix-name dependency)))))) + (update (lambda (state new-queue) + (match state + (((head . tail) . done) + (make-state (lset-difference + equal? + (lset-union equal? new-queue tail) + done) + (cons head done))))))) + (stream-cons + package + (stream-unfold + ;; map: produce a stream element + (lambda (state) + (cran->guix-package (next state) repo)) + + ;; predicate + (compose not done?) + + ;; generator: update the queue + (lambda (state) + (receive (package . dependencies) + (cran->guix-package (next state) repo) + (if package + (update state (filter (cut unknown? <> + (cons (next state) + (imported state))) + (car dependencies))) + ;; TODO: Try the other archives before giving up + (update state (imported state))))) + + ;; initial state + (make-state (filter unknown? (car dependencies)) + (list package-name)))))))) ;;; diff --git a/guix/import/crate.scm b/guix/import/crate.scm new file mode 100644 index 0000000000..233a20e983 --- /dev/null +++ b/guix/import/crate.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; +;;; 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 import crate) + #:use-module (guix base32) + #:use-module (guix build-system cargo) + #:use-module ((guix download) #:prefix download:) + #:use-module (guix hash) + #:use-module (guix http-client) + #:use-module (guix import json) + #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) ; recursive + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) + #:export (crate->guix-package + guix-package->crate-name + %crate-updater)) + +(define (crate-fetch crate-name callback) + "Fetch the metadata for CRATE-NAME from crates.io and call the callback." + + (define (crates->inputs crates) + (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?)) + + (define (string->license string) + (map spdx-string->license (string-split string #\/))) + + (define (crate-kind-predicate kind) + (lambda (dep) (string=? (assoc-ref dep "kind") kind))) + + (and-let* ((crate-json (json-fetch (string-append crate-url crate-name))) + (crate (assoc-ref crate-json "crate")) + (name (assoc-ref crate "name")) + (version (assoc-ref crate "max_version")) + (homepage (assoc-ref crate "homepage")) + (repository (assoc-ref crate "repository")) + (synopsis (assoc-ref crate "description")) + (description (assoc-ref crate "description")) + (license (string->license (assoc-ref crate "license"))) + (path (string-append "/" version "/dependencies")) + (deps-json (json-fetch (string-append crate-url name path))) + (deps (assoc-ref deps-json "dependencies")) + (input-crates (filter (crate-kind-predicate "normal") deps)) + (native-input-crates + (filter (lambda (dep) + (not ((crate-kind-predicate "normal") dep))) deps)) + (inputs (crates->inputs input-crates)) + (native-inputs (crates->inputs native-input-crates)) + (home-page (match homepage + (() repository) + (_ homepage)))) + (callback #:name name #:version version + #:inputs inputs #:native-inputs native-inputs + #:home-page home-page #:synopsis synopsis + #:description description #:license license))) + +(define* (make-crate-sexp #:key name version inputs native-inputs + home-page synopsis description license + #:allow-other-keys) + "Return the `package' s-expression for a rust package with the given NAME, +VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." + (let* ((port (http-fetch (crate-uri name version))) + (guix-name (crate-name->package-name name)) + (inputs (map crate-name->package-name inputs)) + (native-inputs (map crate-name->package-name native-inputs)) + (pkg `(package + (name ,guix-name) + (version ,version) + (source (origin + (method url-fetch) + (uri (crate-uri ,name version)) + (file-name (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + ,(bytevector->nix-base32-string (port-sha256 port)))))) + (build-system cargo-build-system) + ,@(maybe-native-inputs native-inputs "src") + ,@(maybe-inputs inputs "src") + (home-page ,(match home-page + (() "") + (_ home-page))) + (synopsis ,synopsis) + (description ,(beautify-description description)) + (license ,(match license + (() #f) + ((license) license) + (_ `(list ,@license))))))) + (close-port port) + pkg)) + +(define (crate->guix-package crate-name) + "Fetch the metadata for CRATE-NAME from crates.io, and return the +`package' s-expression corresponding to that package, or #f on failure." + (crate-fetch crate-name make-crate-sexp)) + +(define (guix-package->crate-name package) + "Return the crate name of PACKAGE." + (and-let* ((origin (package-source package)) + (uri (origin-uri origin)) + (crate-url? uri) + (len (string-length crate-url)) + (path (xsubstring uri len)) + (parts (string-split path #\/))) + (match parts + ((name _ ...) name)))) + +(define (crate-name->package-name name) + (string-append "rust-" (string-join (string-split name #\_) "-"))) + +;;; +;;; Updater +;;; + +(define (crate-package? package) + "Return true if PACKAGE is a Rust crate from crates.io." + (let ((source-url (and=> (package-source package) origin-uri)) + (fetch-method (and=> (package-source package) origin-method))) + (and (eq? fetch-method download:url-fetch) + (match source-url + ((? string?) + (crate-url? source-url)) + ((source-url ...) + (any crate-url? source-url)))))) + +(define (latest-release package) + "Return an <upstream-source> for the latest release of PACKAGE." + (let* ((crate-name (guix-package->crate-name package)) + (callback (lambda* (#:key version #:allow-other-keys) version)) + (version (crate-fetch crate-name callback)) + (url (crate-uri crate-name version))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url))))) + +(define %crate-updater + (upstream-updater + (name 'crates) + (description "Updater for crates.io packages") + (pred crate-package?) + (latest latest-release))) + diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 320a09e8c6..96cf5bbae6 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -89,7 +89,13 @@ NAMES (strings)." "Fetch URL, store the content in a temporary file and call PROC with that file. Returns the value returned by PROC. On error call ERROR-THUNK and return its value or leave if it's false." - (proc (http-fetch/cached (string->uri url)))) + (catch #t + (lambda () + (proc (http-fetch/cached (string->uri url)))) + (lambda (key . args) + (if error-thunk + (error-thunk) + (leave (_ "~A: download failed~%") url))))) (define (is-elpa-package? name elpa-pkg-spec) "Return true if the string NAME corresponds to the name of the package @@ -222,7 +228,7 @@ type '<elpa-package>'." (bytevector->nix-base32-string (file-sha256 tarball)) "failed to download package"))))) (build-system emacs-build-system) - ,@(maybe-inputs 'inputs dependencies) + ,@(maybe-inputs 'propagated-inputs dependencies) (home-page ,(elpa-package-home-page pkg)) (synopsis ,(elpa-package-synopsis pkg)) (description ,(elpa-package-description pkg)) diff --git a/guix/import/github.scm b/guix/import/github.scm index 0843ddeefd..01452b12e3 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -23,23 +23,12 @@ #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) + #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (web uri) #:export (%github-updater)) -(define (json-fetch* url) - "Return a list/hash representation of the JSON resource URL, or #f on -failure." - (call-with-output-file "/dev/null" - (lambda (null) - (with-error-to-port null - (lambda () - (call-with-temporary-output-file - (lambda (temp port) - (and (url-fetch url temp) - (call-with-input-file temp json->scm))))))))) - (define (find-extension url) "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" @@ -136,7 +125,7 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" "https://api.github.com/repos/" (github-user-slash-repository url) "/releases")) - (json (json-fetch* + (json (json-fetch (if token (string-append api-url "?access_token=" token) api-url)))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 9794ff9757..7cce0fc594 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -303,7 +303,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." "Return true if PACKAGE is a Python package from PyPI." (define (pypi-url? url) - (string-prefix? "https://pypi.python.org/" url)) + (or (string-prefix? "https://pypi.python.org/" url) + (string-prefix? "https://pypi.io/packages" url))) (let ((source-url (and=> (package-source package) origin-uri)) (fetch-method (and=> (package-source package) origin-method))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 057c2d9c7d..be1980d08f 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -22,6 +22,7 @@ #:use-module (guix base32) #:use-module ((guix build download) #:prefix build:) #:use-module (guix hash) + #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) #:use-module (ice-9 match) @@ -36,6 +37,10 @@ url-fetch guix-hash-url + maybe-inputs + maybe-native-inputs + package->definition + spdx-string->license license->symbol @@ -205,3 +210,34 @@ into a proper sentence and by using two spaces between sentences." ;; Use double spacing between sentences (regexp-substitute/global #f "\\. \\b" cleaned 'pre ". " 'post))) + +(define* (package-names->package-inputs names #:optional (output #f)) + (map (lambda (input) + (cons* input (list 'unquote (string->symbol input)) + (or (and output (list output)) + '()))) + names)) + +(define* (maybe-inputs package-names #:optional (output #f)) + "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a +package definition." + (match (package-names->package-inputs package-names output) + (() + '()) + ((package-inputs ...) + `((inputs (,'quasiquote ,package-inputs)))))) + +(define* (maybe-native-inputs package-names #:optional (output #f)) + "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a +package definition." + (match (package-names->package-inputs package-names output) + (() + '()) + ((package-inputs ...) + `((native-inputs (,'quasiquote ,package-inputs)))))) + +(define (package->definition guix-package) + (match guix-package + (('package ('name (? string? name)) _ ...) + `(define-public ,(string->symbol name) + ,guix-package)))) diff --git a/guix/profiles.scm b/guix/profiles.scm index 0b317ef51e..e7707b6543 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -919,10 +919,14 @@ files for the truetype fonts of the @var{manifest} entries." (define* (profile-derivation manifest #:key (hooks %default-profile-hooks) + (locales? #t) system) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by -the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." +the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc. + +When LOCALES? is true, the build is performed under a UTF-8 locale; this adds +a dependency on the 'glibc-utf8-locales' package." (mlet %store-monad ((system (if system (return system) (current-system))) @@ -939,6 +943,19 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." extras) (manifest-inputs manifest))) + (define glibc-utf8-locales ;lazy reference + (module-ref (resolve-interface '(gnu packages base)) + 'glibc-utf8-locales)) + + (define set-utf8-locale + ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so + ;; install a UTF-8 locale. + #~(begin + (setenv "LOCPATH" + #$(file-append glibc-utf8-locales "/lib/locale/" + (package-version glibc-utf8-locales))) + (setlocale LC_ALL "en_US.utf8"))) + (define builder (with-imported-modules '((guix build profiles) (guix build union) @@ -953,6 +970,8 @@ the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc." (setvbuf (current-output-port) _IOLBF) (setvbuf (current-error-port) _IOLBF) + #+(if locales? set-utf8-locale #t) + (define search-paths ;; Search paths of MANIFEST's packages, converted back to their ;; record form. @@ -1099,7 +1118,8 @@ case when generations have been deleted (there are \"holes\")." "Link GENERATION, a string, to the empty profile. An error is raised if that fails." (let* ((drv (run-with-store store - (profile-derivation (manifest '())))) + (profile-derivation (manifest '()) + #:locales? #f))) (prof (derivation->output-path drv "out"))) (build-derivations store (list drv)) (switch-symlinks generation prof))) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 400353247c..9e49c53635 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +42,13 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 binary-ports) - #:export (guix-archive)) + #:export (guix-archive + options->derivations+files)) + +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See <http://bugs.gnu.org/12202>. +(module-autoload! (current-module) + '(guix docker) '(build-docker-image)) ;;; @@ -50,7 +57,8 @@ (define %default-options ;; Alist of default option values. - `((system . ,(%current-system)) + `((format . "nar") + (system . ,(%current-system)) (substitutes? . #t) (graft? . #t) (max-silent-time . 3600) @@ -62,6 +70,8 @@ Export/import one or more packages from/to the store.\n")) (display (_ " --export export the specified files/packages to stdout")) (display (_ " + --format=FMT export files/packages in the specified format FMT")) + (display (_ " -r, --recursive combined with '--export', include dependencies")) (display (_ " --import import from the archive passed on stdin")) @@ -116,6 +126,9 @@ Export/import one or more packages from/to the store.\n")) (option '("export") #f #f (lambda (opt name arg result) (alist-cons 'export #t result))) + (option '(#\f "format") #t #f + (lambda (opt name arg result . rest) + (alist-cons 'format arg result))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'export-recursive? #t result))) @@ -245,8 +258,21 @@ resulting archive to the standard output port." (if (or (assoc-ref opts 'dry-run?) (build-derivations store drv)) - (export-paths store files (current-output-port) - #:recursive? (assoc-ref opts 'export-recursive?)) + (match (assoc-ref opts 'format) + ("nar" + (export-paths store files (current-output-port) + #:recursive? (assoc-ref opts 'export-recursive?))) + ("docker" + (match files + ((file) + (let ((system (assoc-ref opts 'system))) + (format #t "~a\n" + (build-docker-image file #:system system)))) + (_ + ;; TODO: Remove this restriction. + (leave (_ "only a single item can be exported to Docker~%"))))) + (format + (leave (_ "~a: unknown archive format~%") format))) (leave (_ "unable to export the given packages~%"))))) (define (generate-key-pair parameters) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8c2c4902fc..ccb4c275fc 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -151,7 +151,11 @@ the new package's version number from URI." ;; Use #:recursive? #t to allow for directories. (source (download-to-store store uri - #:recursive? #t)))))) + #:recursive? #t)) + + ;; Override the replacement, otherwise '--with-source' would + ;; have no effect. + (replacement #f))))) ;;; diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 590d8f1099..9ab4fbe2a9 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -118,7 +118,7 @@ taken since we do not import the archives." (select-reference item narinfos urls) (narinfo-hash->sha256 (narinfo-hash first)))))) (() - (leave (_ "no substitutes for '~a'~%") item)))) + (warning (_ "no substitutes for '~a'; cannot conclude~%") item)))) (mlet* %store-monad ((local (mapm %store-monad query-locally-built-hash items)) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm new file mode 100644 index 0000000000..9ae204e6c6 --- /dev/null +++ b/guix/scripts/copy.scm @@ -0,0 +1,207 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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 copy) + #:use-module (guix ui) + #:use-module (guix scripts) + #:use-module (guix ssh) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix scripts build) + #:use-module ((guix scripts archive) #:select (options->derivations+files)) + #:use-module (ssh session) + #:use-module (ssh auth) + #:use-module (ssh key) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-copy)) + + +;;; +;;; Exchanging store items over SSH. +;;; + +(define %compression + "zlib@openssh.com,zlib") + +(define* (open-ssh-session host #:key user port) + "Open an SSH session for HOST and return it. When USER and PORT are #f, use +default values or whatever '~/.ssh/config' specifies; otherwise use them. +Throw an error on failure." + (let ((session (make-session #:user user + #:host host + #:port port + #:timeout 10 ;seconds + ;; #:log-verbosity 'protocol + + ;; We need lightweight compression when + ;; exchanging full archives. + #:compression %compression + #:compression-level 3))) + + ;; Honor ~/.ssh/config. + (session-parse-config! session) + + (match (connect! session) + ('ok + ;; Let the SSH agent authenticate us to the server. + (match (userauth-agent! session) + ('success + session) + (x + (disconnect! session) + (leave (_ "SSH authentication failed for '~a': ~a~%") + host (get-error session))))) + (x + ;; Connection failed or timeout expired. + (leave (_ "SSH connection to '~a' failed: ~a~%") + host (get-error session)))))) + +(define (ssh-spec->user+host+port spec) + "Parse SPEC, a string like \"user@host:port\" or just \"host\", and return +three values: the user name (or #f), the host name, and the TCP port +number (or #f) corresponding to SPEC." + (define tokens + (char-set #\@ #\:)) + + (match (string-tokenize spec (char-set-complement tokens)) + ((host) + (values #f host #f)) + ((left right) + (if (string-index spec #\@) + (values left right #f) + (values #f left (string->number right)))) + ((user host port) + (match (string->number port) + ((? integer? port) + (values user host port)) + (x + (leave (_ "~a: invalid TCP port number~%") port)))) + (x + (leave (_ "~a: invalid SSH specification~%") spec)))) + +(define (send-to-remote-host target opts) + "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; +package names, build the underlying packages before sending them." + (with-store local + (set-build-options-from-command-line local opts) + (let-values (((user host port) + (ssh-spec->user+host+port target)) + ((drv items) + (options->derivations+files local opts))) + (show-what-to-build local drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) + + (and (or (assoc-ref opts 'dry-run?) + (build-derivations local drv)) + (let* ((session (open-ssh-session host #:user user #:port port)) + (sent (send-files local items + (connect-to-remote-daemon session) + #:recursive? #t))) + (format #t "~{~a~%~}" sent) + sent))))) + +(define (retrieve-from-remote-host source opts) + "Retrieve ITEMS from SOURCE." + (with-store local + (let*-values (((user host port) + (ssh-spec->user+host+port source)) + ((session) + (open-ssh-session host #:user user #:port port)) + ((remote) + (connect-to-remote-daemon session))) + (set-build-options-from-command-line local opts) + ;; TODO: Here we could to compute and build the derivations on REMOTE + ;; rather than on LOCAL (one-off offloading) but that is currently too + ;; slow due to the many RPC round trips. So we just assume that REMOTE + ;; contains ITEMS. + (let*-values (((drv items) + (options->derivations+files local opts)) + ((retrieved) + (retrieve-files local items remote #:recursive? #t))) + (format #t "~{~a~%~}" retrieved) + retrieved)))) + + +;;; +;;; Options. +;;; + +(define (show-help) + (display (_ "Usage: guix copy [OPTION]... ITEMS... +Copy ITEMS to or from the specified host over SSH.\n")) + (display (_ " + --to=HOST send ITEMS to HOST")) + (display (_ " + --from=HOST receive ITEMS from HOST")) + (newline) + (show-build-options-help) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specifications of the command-line options. + (cons* (option '("to") #t #f + (lambda (opt name arg result) + (alist-cons 'destination arg result))) + (option '("from") #t #f + (lambda (opt name arg result) + (alist-cons 'source arg result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix copy"))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) + %standard-build-options)) + +(define %default-options + `((system . ,(%current-system)) + (substitutes? . #t) + (graft? . #t) + (max-silent-time . 3600) + (verbosity . 0))) + + +;;; +;;; Entry point. +;;; + +(define (guix-copy . args) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options))) + (source (assoc-ref opts 'source)) + (target (assoc-ref opts 'destination))) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (_ "use '--to' or '--from'~%"))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6dea67ca22..1d3be6a84f 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -155,6 +155,9 @@ COMMAND or an interactive shell in that environment.\n")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " + -r, --root=FILE make FILE a symlink to the result, and register it + as a garbage collector root")) + (display (_ " -C, --container run command within an isolated container")) (display (_ " -N, --network allow containers to access the network")) @@ -247,6 +250,9 @@ COMMAND or an interactive shell in that environment.\n")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\r "root") #t #f + (lambda (opt name arg result) + (alist-cons 'gc-root arg result))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -323,7 +329,8 @@ profile." #:system system #:hooks (if bootstrap? '() - %default-profile-hooks))) + %default-profile-hooks) + #:locales? (not bootstrap?))) (define requisites* (store-lift requisites)) @@ -522,7 +529,26 @@ message if any test fails." (report-error (_ "cannot create container: /proc/self/setgroups does not exist\n")) (leave (_ "is your kernel version < 3.19?\n")))) -;; Entry point. +(define (register-gc-root target root) + "Make ROOT an indirect root to TARGET. This is procedure is idempotent." + (let* ((root (string-append (canonicalize-path (dirname root)) + "/" root))) + (catch 'system-error + (lambda () + (symlink target root) + ((store-lift add-indirect-root) root)) + (lambda args + (if (and (= EEXIST (system-error-errno args)) + (equal? (false-if-exception (readlink root)) target)) + (with-monad %store-monad + (return #t)) + (apply throw args)))))) + + +;;; +;;; Entry point. +;;; + (define (guix-environment . args) (with-error-handling (let* ((opts (parse-args args)) @@ -578,7 +604,9 @@ message if any test fails." system)) (prof-drv (inputs->profile-derivation inputs system bootstrap?)) - (profile -> (derivation->output-path prof-drv))) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + ;; First build the inputs. This is necessary even for ;; --search-paths. Additionally, we might need to build bash for ;; a container. @@ -587,6 +615,9 @@ message if any test fails." (list prof-drv bash) (list prof-drv)) opts) + (mwhen gc-root + (register-gc-root profile gc-root)) + (cond ((assoc-ref opts 'dry-run?) (return #t)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2f70d64c90..79ce503a2e 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type @@ -103,6 +104,25 @@ name." ;;; +;;; Reverse package DAG. +;;; + +(define %reverse-package-node-type + ;; For this node type we first need to compute the list of packages and the + ;; list of back-edges. Since we want to do it only once, we use the + ;; promises below. + (let* ((packages (delay (fold-packages cons '()))) + (back-edges (delay (run-with-store #f ;store not actually needed + (node-back-edges %package-node-type + (force packages)))))) + (node-type + (inherit %package-node-type) + (name "reverse-package") + (description "the reverse DAG of packages") + (edges (lift1 (force back-edges) %store-monad))))) + + +;;; ;;; Package DAG using bags. ;;; @@ -323,6 +343,7 @@ substitutes." (define %node-types ;; List of all the node types. (list %package-node-type + %reverse-package-node-type %bag-node-type %bag-with-origins-node-type %bag-emerged-node-type @@ -337,6 +358,13 @@ substitutes." %node-types) (leave (_ "~a: unknown node type~%") name))) +(define (lookup-backend name) + "Return the graph backend called NAME. Raise an error if it is not found." + (or (find (lambda (backend) + (string=? (graph-backend-name backend) name)) + %graph-backends) + (leave (_ "~a: unknown backend~%") name))) + (define (list-node-types) "Print the available node types along with their synopsis." (display (_ "The available node types are:\n")) @@ -347,6 +375,16 @@ substitutes." (node-type-description type))) %node-types)) +(define (list-backends) + "Print the available backends along with their synopsis." + (display (_ "The available backend types are:\n")) + (newline) + (for-each (lambda (backend) + (format #t " - ~a: ~a~%" + (graph-backend-name backend) + (graph-backend-description backend))) + %graph-backends)) + ;;; ;;; Command-line options. @@ -361,6 +399,14 @@ substitutes." (lambda (opt name arg result) (list-node-types) (exit 0))) + (option '(#\b "backend") #t #f + (lambda (opt name arg result) + (alist-cons 'backend (lookup-backend arg) + result))) + (option '("list-backends") #f #f + (lambda (opt name arg result) + (list-backends) + (exit 0))) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) @@ -378,6 +424,10 @@ substitutes." (display (_ "Usage: guix graph PACKAGE... Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (display (_ " + -b, --backend=TYPE produce a graph with the given backend TYPE")) + (display (_ " + --list-backends list the available graph backends")) + (display (_ " -t, --type=TYPE represent nodes of the given TYPE")) (display (_ " --list-types list the available graph types")) @@ -392,7 +442,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (show-bug-report-information)) (define %default-options - `((node-type . ,%package-node-type))) + `((node-type . ,%package-node-type) + (backend . ,%graphviz-backend))) ;;; @@ -407,6 +458,7 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (lambda (arg result) (alist-cons 'argument arg result)) %default-options)) + (backend (assoc-ref opts 'backend)) (type (assoc-ref opts 'node-type)) (items (filter-map (match-lambda (('argument . (? store-path? item)) @@ -429,7 +481,8 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) items))) (export-graph (concatenate nodes) (current-output-port) - #:node-type type))))))) + #:node-type type + #:backend backend))))))) #t) ;;; graph.scm ends here diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index a339a8556b..640b2417d2 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; 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> ;;; @@ -116,6 +116,9 @@ and 'hexadecimal' can be used as well).\n")) (case (stat:type stat) ((directory) (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + ((regular) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git")) (else #f))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index e54744feca..4d07e0fd69 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -73,7 +73,7 @@ rather than \\n." ;;; Entry point. ;;; -(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran")) +(define importers '("gnu" "nix" "pypi" "cpan" "hackage" "elpa" "gem" "cran" "crate")) (define (resolve-importer name) (let ((module (resolve-interface @@ -107,10 +107,17 @@ Run IMPORTER with ARGS.\n")) (show-version-and-exit "guix import")) ((importer args ...) (if (member importer importers) - (match (apply (resolve-importer importer) args) - ((and expr ('package _ ...)) - (pretty-print expr (newline-rewriting-port - (current-output-port)))) - (x - (leave (_ "'~a' import failed~%") importer))) + (let ((print (lambda (expr) + (pretty-print expr (newline-rewriting-port + (current-output-port)))))) + (match (apply (resolve-importer importer) args) + ((and expr ('package _ ...)) + (print expr)) + ((? list? expressions) + (for-each (lambda (expr) + (print expr) + (newline)) + expressions)) + (x + (leave (_ "'~a' import failed~%") importer)))) (leave (_ "~a: invalid importer~%") importer))))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index ace1123b90..66c660ae14 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-cran)) @@ -63,6 +64,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (lambda (opt name arg result) (alist-cons 'repo (string->symbol arg) (alist-delete 'repo result)))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -88,12 +92,22 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (cran->guix-package package-name - (or (assoc-ref opts 'repo) 'cran)))) - (unless sexp - (leave (_ "failed to download description for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (stream->list (recursive-import package-name + (or (assoc-ref opts 'repo) 'cran)))) + ;; Single import + (let ((sexp (cran->guix-package package-name + (or (assoc-ref opts 'repo) 'cran)))) + (unless sexp + (leave (_ "failed to download description for package '~a'~%") + package-name)) + sexp))) (() (leave (_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm new file mode 100644 index 0000000000..4337a0b623 --- /dev/null +++ b/guix/scripts/import/crate.scm @@ -0,0 +1,94 @@ + +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2016 David Craven <david@craven.ch> +;;; +;;; 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 import crate) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import crate) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-crate)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (_ "Usage: guix import crate PACKAGE-NAME +Import and convert the crate.io package for PACKAGE-NAME.\n")) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import crate"))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-crate . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (let ((sexp (crate->guix-package package-name))) + (unless sexp + (leave (_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp)) + (() + (leave (_ "too few arguments~%"))) + ((many ...) + (leave (_ "too many arguments~%")))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index c98cf8c534..6a4ae28689 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -27,6 +27,7 @@ #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) + #:use-module (guix ssh) #:use-module (guix store) #:use-module (guix derivations) #:use-module ((guix serialization) @@ -221,53 +222,6 @@ instead of '~a' of type '~a'~%") (leave (_ "failed to connect to '~a': ~a~%") (build-machine-name machine) (get-error session)))))) -(define* (connect-to-remote-daemon session - #:optional - (socket-name "/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." - (define redirect - ;; Code run in SESSION to redirect the remote process' stdin/stdout to the - ;; daemon's socket, à la socat. The SSH protocol supports forwarding to - ;; Unix-domain sockets but libssh doesn't have an API for that, hence this - ;; hack. - `(begin - (use-modules (ice-9 match) (rnrs io ports)) - - (let ((sock (socket AF_UNIX SOCK_STREAM 0)) - (stdin (current-input-port)) - (stdout (current-output-port))) - (setvbuf stdin _IONBF) - (setvbuf stdout _IONBF) - (connect sock AF_UNIX ,socket-name) - - (let loop () - (match (select (list stdin sock) '() (list stdin stdout sock)) - ((reads writes ()) - (when (memq stdin reads) - (match (get-bytevector-some stdin) - ((? eof-object?) - (primitive-exit 0)) - (bv - (put-bytevector sock bv)))) - (when (memq sock reads) - (match (get-bytevector-some sock) - ((? eof-object?) - (primitive-exit 0)) - (bv - (put-bytevector stdout bv)))) - (loop)) - (_ - (primitive-exit 1))))))) - - (let ((channel - (open-remote-pipe* session OPEN_BOTH - ;; Sort-of shell-quote REDIRECT. - "guile" "-c" - (object->string - (object->string redirect))))) - (open-connection #:port channel))) - ;;; ;;; Synchronization. @@ -382,8 +336,9 @@ MACHINE." ;; Protect DRV from garbage collection. (add-temp-root store (derivation-file-name drv)) - (send-files (cons (derivation-file-name drv) inputs) - store) + (with-store local + (send-files local (cons (derivation-file-name drv) inputs) store + #:log-port (current-output-port))) (format (current-error-port) "offloading '~a' to '~a'...~%" (derivation-file-name drv) (build-machine-name machine)) (format (current-error-port) "@ build-remote ~a ~a~%" @@ -401,93 +356,17 @@ MACHINE." (parameterize ((current-build-output-port (build-log-port))) (build-derivations store (list drv)))) - (retrieve-files outputs store) + (retrieve-files* outputs store) (format (current-error-port) "done with offloaded '~a'~%" (derivation-file-name drv))) -(define (store-import-channel session) - "Return an output port to which archives to be exported to SESSION's store -can be written." - ;; Using the 'import-paths' RPC on a remote store would be slow because it - ;; makes a round trip every time 32 KiB have been transferred. This - ;; procedure instead opens a separate channel to use the remote - ;; 'import-paths' procedure, which consumes all the data in a single round - ;; trip. - (define import - `(begin - (use-modules (guix)) - - (with-store store - (setvbuf (current-input-port) _IONBF) - (import-paths store (current-input-port))))) - - (open-remote-output-pipe session - (string-join - `("guile" "-c" - ,(object->string - (object->string import)))))) - -(define (store-export-channel session files) - "Return an input port from which an export of FILES from SESSION's store can -be read." - ;; Same as above: this is more efficient than calling 'export-paths' on a - ;; remote store. - (define export - `(begin - (use-modules (guix)) - - (with-store store - (setvbuf (current-output-port) _IONBF) - (export-paths store ',files (current-output-port))))) - - (open-remote-input-pipe session - (string-join - `("guile" "-c" - ,(object->string - (object->string export)))))) - -(define (send-files files remote) - "Send the subset of FILES that's missing to REMOTE, a remote store." - (with-store store - ;; Compute the subset of FILES missing on SESSION and send them. - (let* ((session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) - - (with-store store - (remove (cut valid-path? store <>) - ',files))))) - (count (length missing)) - (port (store-import-channel session))) - (format #t (N_ "sending ~a store item to '~a'...~%" - "sending ~a store items to '~a'...~%" count) - count (session-get session 'host)) - - ;; Send MISSING in topological order. - (export-paths store missing port) - - ;; Tell the remote process that we're done. (In theory the - ;; end-of-archive mark of 'export-paths' would be enough, but in - ;; practice it's not.) - (channel-send-eof port) - - ;; Wait for completion of the remote process. - (let ((result (zero? (channel-get-exit-status port)))) - (close-port port) - result)))) - -(define (retrieve-files files remote) - "Retrieve FILES from SESSION's store, and import them." - (let* ((session (channel-get-session (nix-server-socket remote))) - (host (session-get session 'host)) - (port (store-export-channel session files)) - (count (length files))) +(define (retrieve-files* files remote) + "Retrieve FILES from REMOTE and import them using 'restore-file-set'." + (let-values (((port count) + (file-retrieval-port files remote))) (format #t (N_ "retrieving ~a store item from '~a'...~%" "retrieving ~a store items from '~a'...~%" count) - count host) + count (remote-store-host remote)) ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. @@ -677,8 +556,8 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (delay (seed->random-state (logxor (getpid) (car (gettimeofday)))))) -(define (nonce) - (string-append (gethostname) "-" +(define* (nonce #:optional (name (gethostname))) + (string-append name "-" (number->string (random 1000000 (force %random-state))))) (define (assert-node-can-import node name daemon-socket) @@ -687,7 +566,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." (with-store store (let* ((item (add-text-to-store store "export-test" (nonce))) (remote (connect-to-remote-daemon session daemon-socket))) - (send-files (list item) remote) + (with-store local + (send-files local (list item) remote)) + (if (valid-path? remote item) (info (_ "'~a' successfully imported '~a'~%") name item) @@ -698,10 +579,9 @@ allowed on MACHINE. Return +∞ if MACHINE is unreachable." "Bail out if we cannot import signed archives from NODE." (let* ((session (node-session node)) (remote (connect-to-remote-daemon session daemon-socket)) - (item (add-text-to-store remote "import-test" (nonce))) - (port (store-export-channel session (list item)))) + (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store - (if (and (import-paths store port) + (if (and (retrieve-files store (list item) remote) (valid-path? store item)) (info (_ "successfully imported '~a' from '~a'~%") item name) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 96a22f6fab..9e5b7f3c75 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -200,7 +200,8 @@ specified in MANIFEST, a manifest object." (profile-derivation manifest #:hooks (if bootstrap? '() - %default-profile-hooks)))) + %default-profile-hooks) + #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) #:use-substitutes? use-substitutes? @@ -576,11 +577,12 @@ upgrading, #f otherwise." (define (store-item->manifest-entry item) "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name." (let-values (((name version) - (package-name->name+version (store-path-package-name item)))) + (package-name->name+version (store-path-package-name item) + #\-))) (manifest-entry (name name) (version version) - (output #f) + (output "out") ;XXX: wild guess (item item)))) (define (options->installable opts manifest transaction) diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index 0d2e7089aa..59ade0a8c1 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,7 +19,7 @@ (define-module (guix scripts perform-download) #:use-module (guix ui) #:use-module (guix derivations) - #:use-module ((guix store) #:select (derivation-path?)) + #:use-module ((guix store) #:select (derivation-path? store-path?)) #:use-module (guix build download) #:use-module (ice-9 match) #:export (guix-perform-download)) @@ -41,17 +41,23 @@ (module-use! module (resolve-interface '(guix base32))) module)) -(define (perform-download drv) - "Perform the download described by DRV, a fixed-output derivation." +(define* (perform-download drv #:optional output) + "Perform the download described by DRV, a fixed-output derivation, to +OUTPUT. + +Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the +actual output is different from that when we're doing a 'bmCheck' or +'bmRepair' build." (derivation-let drv ((url "url") - (output "out") + (output* "out") (executable "executable") (mirrors "mirrors") (content-addressed-mirrors "content-addressed-mirrors")) (unless url (leave (_ "~a: missing URL~%") (derivation-file-name drv))) - (let* ((url (call-with-input-string url read)) + (let* ((output (or output output*)) + (url (call-with-input-string url read)) (drv-output (assoc-ref (derivation-outputs drv) "out")) (algo (derivation-output-hash-algo drv-output)) (hash (derivation-output-hash drv-output))) @@ -91,20 +97,25 @@ the daemon and not explicitly described as an input of the derivation. This allows us to sidestep bootstrapping problems, such downloading the source code of GnuTLS over HTTPS, before we have built GnuTLS. See <http://bugs.gnu.org/22774>." + + ;; This program must be invoked by guix-daemon under an unprivileged UID to + ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code + ;; execution via the content-addressed mirror procedures. (That means we + ;; exclude users who did not pass '--build-users-group'.) (with-error-handling (match args - (((? derivation-path? drv)) - ;; This program must be invoked by guix-daemon under an unprivileged - ;; UID to prevent things downloading from 'file:///etc/shadow' or - ;; arbitrary code execution via the content-addressed mirror - ;; procedures. (That means we exclude users who did not pass - ;; '--build-users-group'.) + (((? derivation-path? drv) (? store-path? output)) + (assert-low-privileges) + (perform-download (call-with-input-file drv read-derivation) + output)) + (((? derivation-path? drv)) ;backward compatibility (assert-low-privileges) (perform-download (call-with-input-file drv read-derivation))) (("--version") (show-version-and-exit)) (x - (leave (_ "fixed-output derivation name expected~%")))))) + (leave + (_ "fixed-output derivation and output file name expected~%")))))) ;; Local Variables: ;; eval: (put 'derivation-let 'scheme-indent-function 2) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index f8fb3f80ca..0dd7eee974 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -209,7 +209,8 @@ unavailable optional dependencies such as Guile-JSON." ((guix import cpan) => %cpan-updater) ((guix import pypi) => %pypi-updater) ((guix import gem) => %gem-updater) - ((guix import github) => %github-updater))) + ((guix import github) => %github-updater) + ((guix import crate) => %crate-updater))) (define (lookup-updater-by-name name) "Return the updater called NAME." diff --git a/guix/ssh.scm b/guix/ssh.scm new file mode 100644 index 0000000000..3548243839 --- /dev/null +++ b/guix/ssh.scm @@ -0,0 +1,226 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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 ssh) + #:use-module (guix store) + #:autoload (guix ui) (N_) + #:use-module (ssh channel) + #:use-module (ssh popen) + #:use-module (ssh session) + #:use-module (ssh dist) + #:use-module (ssh dist node) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) + #:export (connect-to-remote-daemon + send-files + retrieve-files + remote-store-host + + file-retrieval-port)) + +;;; Commentary: +;;; +;;; This module provides tools to support communication with remote stores +;;; over SSH, using Guile-SSH. +;;; +;;; Code: + +(define* (connect-to-remote-daemon session + #:optional + (socket-name "/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." + (define redirect + ;; Code run in SESSION to redirect the remote process' stdin/stdout to the + ;; daemon's socket, à la socat. The SSH protocol supports forwarding to + ;; Unix-domain sockets but libssh doesn't have an API for that, hence this + ;; hack. + `(begin + (use-modules (ice-9 match) (rnrs io ports)) + + (let ((sock (socket AF_UNIX SOCK_STREAM 0)) + (stdin (current-input-port)) + (stdout (current-output-port))) + (setvbuf stdin _IONBF) + (setvbuf stdout _IONBF) + (connect sock AF_UNIX ,socket-name) + + (let loop () + (match (select (list stdin sock) '() (list stdin stdout sock)) + ((reads writes ()) + (when (memq stdin reads) + (match (get-bytevector-some stdin) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector sock bv)))) + (when (memq sock reads) + (match (get-bytevector-some sock) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector stdout bv)))) + (loop)) + (_ + (primitive-exit 1))))))) + + (let ((channel + (open-remote-pipe* session OPEN_BOTH + ;; Sort-of shell-quote REDIRECT. + "guile" "-c" + (object->string + (object->string redirect))))) + (open-connection #:port channel))) + +(define (store-import-channel session) + "Return an output port to which archives to be exported to SESSION's store +can be written." + ;; Using the 'import-paths' RPC on a remote store would be slow because it + ;; makes a round trip every time 32 KiB have been transferred. This + ;; procedure instead opens a separate channel to use the remote + ;; 'import-paths' procedure, which consumes all the data in a single round + ;; trip. + (define import + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-input-port) _IONBF) + + ;; FIXME: Exceptions are silently swallowed. We should report them + ;; somehow. + (import-paths store (current-input-port))))) + + (open-remote-output-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string import)))))) + +(define* (store-export-channel session files + #:key recursive?) + "Return an input port from which an export of FILES from SESSION's store can +be read. When RECURSIVE? is true, the closure of FILES is exported." + ;; Same as above: this is more efficient than calling 'export-paths' on a + ;; remote store. + (define export + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-output-port) _IONBF) + + ;; FIXME: Exceptions are silently swallowed. We should report them + ;; somehow. + (export-paths store ',files (current-output-port) + #:recursive? ,recursive?)))) + + (open-remote-input-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string export)))))) + +(define* (send-files local files remote + #:key + recursive? + (log-port (current-error-port))) + "Send the subset of FILES from LOCAL (a local store) that's missing to +REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES. +Return the list of store items actually sent." + ;; Compute the subset of FILES missing on SESSION and send them. + (let* ((files (if recursive? (requisites local files) files)) + (session (channel-get-session (nix-server-socket remote))) + (node (make-node session)) + (missing (node-eval node + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',files))))) + (count (length missing)) + (port (store-import-channel session))) + (format log-port (N_ "sending ~a store item to '~a'...~%" + "sending ~a store items to '~a'...~%" count) + count (session-get session 'host)) + + ;; Send MISSING in topological order. + (export-paths local missing port) + + ;; Tell the remote process that we're done. (In theory the end-of-archive + ;; mark of 'export-paths' would be enough, but in practice it's not.) + (channel-send-eof port) + + ;; Wait for completion of the remote process. + (let ((result (zero? (channel-get-exit-status port)))) + (close-port port) + missing))) + +(define (remote-store-session remote) + "Return the SSH channel beneath REMOTE, a remote store as returned by +'connect-to-remote-daemon', or #f." + (channel-get-session (nix-server-socket remote))) + +(define (remote-store-host remote) + "Return the name of the host REMOTE is connected to, where REMOTE is a +remote store as returned by 'connect-to-remote-daemon'." + (match (remote-store-session remote) + (#f #f) + ((? session? session) + (session-get session 'host)))) + +(define* (file-retrieval-port files remote + #:key recursive?) + "Return an input port from which to retrieve FILES (a list of store items) +from REMOTE, along with the number of items to retrieve (lower than or equal +to the length of FILES.)" + (values (store-export-channel (remote-store-session remote) files + #:recursive? recursive?) + (length files))) ;XXX: inaccurate when RECURSIVE? is true + +(define* (retrieve-files local files remote + #:key recursive? (log-port (current-error-port))) + "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on +LOCAL. When RECURSIVE? is true, retrieve the closure of FILES." + (let-values (((port count) + (file-retrieval-port files remote + #:recursive? recursive?))) + (format #t (N_ "retrieving ~a store item from '~a'...~%" + "retrieving ~a store items from '~a'...~%" count) + count (remote-store-host remote)) + (when (eof-object? (lookahead-u8 port)) + ;; The failure could be because one of the requested store items is not + ;; valid on REMOTE, or because Guile or Guix is improperly installed. + ;; TODO: Improve error reporting. + (raise (condition + (&message + (message + (format #f + (_ "failed to retrieve store items from '~a'") + (remote-store-host remote))))))) + + (let ((result (import-paths local port))) + (close-port port) + result))) + +;;; ssh.scm ends here diff --git a/guix/ui.scm b/guix/ui.scm index cafb3c6705..7d4c437354 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> @@ -306,7 +306,13 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (display (_ "Copyright (C) 2016 the Guix authors + (format #t "Copyright ~a 2017 ~a" + ;; TRANSLATORS: Translate "(C)" to the copyright symbol + ;; (C-in-a-circle), if this symbol is available in the user's + ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ + (_ "(C)") + (_ "the Guix authors\n")) + (display (_"\ License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. diff --git a/guix/upstream.scm b/guix/upstream.scm index 8685afd860..2334c4c0a6 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -241,12 +241,16 @@ and 'interactive' (default)." ((archive-type) (match (and=> (package-source package) origin-uri) ((? string? uri) - (or (file-extension uri) "gz")) + (file-extension (basename uri))) (_ "gz"))) ((url signature-url) (find2 (lambda (url sig-url) - (string-suffix? archive-type url)) + ;; Some URIs lack a file extension, like + ;; 'https://crates.io/???/0.1/download'. In that + ;; case, pick the first URL. + (or (not archive-type) + (string-suffix? archive-type url))) urls (or signature-urls (circular-list #f))))) (let ((tarball (download-tarball store url signature-url diff --git a/guix/utils.scm b/guix/utils.scm index 06f49daca8..ee06e47fe9 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net> @@ -500,11 +500,13 @@ returned by `config.guess'." ;; cross-building to. (make-parameter #f)) -(define (package-name->name+version spec) +(define* (package-name->name+version spec + #:optional (delimiter #\@)) "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\" and \"0.9.1b\". When the version part is unavailable, SPEC and #f are -returned. Both parts must not contain any '@'." - (match (string-rindex spec #\@) +returned. Both parts must not contain any '@'. Optionally, DELIMITER can be +a character other than '@'." + (match (string-rindex spec delimiter) (#f (values spec #f)) (idx (values (substring spec 0 idx) (substring spec (1+ idx)))))) |