diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/ant.scm | 149 | ||||
| -rw-r--r-- | guix/build-system/gnu.scm | 17 | ||||
| -rw-r--r-- | guix/build/ant-build-system.scm | 160 | ||||
| -rw-r--r-- | guix/build/download.scm | 32 | ||||
| -rw-r--r-- | guix/build/graft.scm | 7 | ||||
| -rw-r--r-- | guix/cve.scm | 66 | ||||
| -rw-r--r-- | guix/derivations.scm | 16 | ||||
| -rw-r--r-- | guix/gexp.scm | 10 | ||||
| -rw-r--r-- | guix/grafts.scm | 192 | ||||
| -rw-r--r-- | guix/http-client.scm | 11 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 12 | ||||
| -rw-r--r-- | guix/import/snix.scm | 10 | ||||
| -rw-r--r-- | guix/licenses.scm | 7 | ||||
| -rw-r--r-- | guix/packages.scm | 241 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 53 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 143 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 13 | ||||
| -rw-r--r-- | guix/scripts/import/hackage.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 50 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 33 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 256 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 8 | ||||
| -rw-r--r-- | guix/store.scm | 71 | ||||
| -rw-r--r-- | guix/tests.scm | 51 | ||||
| -rw-r--r-- | guix/ui.scm | 14 | ||||
| -rw-r--r-- | guix/upstream.scm | 4 | ||||
| -rw-r--r-- | guix/utils.scm | 15 |
29 files changed, 1251 insertions, 405 deletions
diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm new file mode 100644 index 0000000000..d3054e5ffa --- /dev/null +++ b/guix/build-system/ant.scm @@ -0,0 +1,149 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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 build-system ant) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (%ant-build-system-modules + ant-build + ant-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Java packages using Ant. +;; +;; Code: + +(define %ant-build-system-modules + ;; Build-side modules imported by default. + `((guix build ant-build-system) + (guix build syscalls) + ,@%gnu-build-system-modules)) + +(define (default-jdk) + "Return the default JDK package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((jdk-mod (resolve-interface '(gnu packages java)))) + (module-ref jdk-mod 'icedtea))) + +(define (default-ant) + "Return the default Ant package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((jdk-mod (resolve-interface '(gnu packages java)))) + (module-ref jdk-mod 'ant))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (jdk (default-jdk)) + (ant (default-ant)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:jdk #:ant #: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 `(("jdk" ,jdk "jdk") + ("ant" ,ant) + ,@native-inputs)) + (outputs outputs) + (build ant-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (ant-build store name inputs + #:key + (tests? #t) + (test-target "tests") + (configure-flags ''()) + (make-flags ''()) + (build-target "jar") + (jar-name #f) + (phases '(@ (guix build ant-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f)p + (imported-modules %ant-build-system-modules) + (modules '((guix build ant-build-system) + (guix build utils)))) + "Build SOURCE with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (ant-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:make-flags ,make-flags + #:configure-flags ,configure-flags + #:system ,system + #:tests? ,tests? + #:test-target ,test-target + #:build-target ,build-target + #:jar-name ,jar-name + #: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 outputs + #:guile-for-build guile-for-build)) + +(define ant-build-system + (build-system + (name 'ant) + (description "The standard Ant build system") + (lower lower))) + +;;; ant.scm ends here diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index afd57668e2..a7d1952b57 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -296,7 +296,8 @@ standard packages used as implicit inputs of the GNU build system." (imported-modules %gnu-build-system-modules) (modules %default-modules) (substitutable? #t) - allowed-references) + allowed-references + disallowed-references) "Return a derivation called NAME that builds from tarball SOURCE, with input derivation INPUTS, using the usual procedure of the GNU Build System. The builder is run with GUILE, or with the distro's final Guile @@ -313,7 +314,8 @@ SUBSTITUTABLE? determines whether users may be able to use substitutes of the returned derivations, or whether they should always build it locally. ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs -are allowed to refer to." +are allowed to refer to. Likewise for DISALLOWED-REFERENCES, which lists +packages that must not be referenced." (define canonicalize-reference (match-lambda ((? package? p) @@ -378,6 +380,10 @@ are allowed to refer to." (and allowed-references (map canonicalize-reference allowed-references)) + #:disallowed-references + (and disallowed-references + (map canonicalize-reference + disallowed-references)) #:guile-for-build guile-for-build)) @@ -432,7 +438,8 @@ is one of `host' or `target'." (imported-modules %gnu-build-system-modules) (modules %default-modules) (substitutable? #t) - allowed-references) + allowed-references + disallowed-references) "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are cross-built inputs, and NATIVE-INPUTS are inputs that run on the build platform." @@ -524,6 +531,10 @@ platform." (and allowed-references (map canonicalize-reference allowed-references)) + #:disallowed-references + (and disallowed-references + (map canonicalize-reference + disallowed-references)) #:guile-for-build guile-for-build)) (define gnu-build-system diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm new file mode 100644 index 0000000000..d302b948b5 --- /dev/null +++ b/guix/build/ant-build-system.scm @@ -0,0 +1,160 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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 build ant-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (sxml simple) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + ant-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Java packages using +;; Ant. +;; +;; Code: + +(define (default-build.xml jar-name prefix) + "Create a simple build.xml with standard targets for Ant." + (call-with-output-file "build.xml" + (lambda (port) + (sxml->xml + `(project (@ (basedir ".")) + (property (@ (name "classes.dir") + (value "${basedir}/build/classes"))) + (property (@ (name "jar.dir") + (value "${basedir}/build/jar"))) + (property (@ (name "dist.dir") + (value ,prefix))) + + ;; respect the CLASSPATH environment variable + (property (@ (name "build.sysclasspath") + (value "first"))) + (property (@ (environment "env"))) + (path (@ (id "classpath")) + (pathelement (@ (location "${env.CLASSPATH}")))) + + (target (@ (name "compile")) + (mkdir (@ (dir "${classes.dir}"))) + (javac (@ (includeantruntime "false") + (srcdir "src") + (destdir "${classes.dir}") + (classpath (@ (refid "classpath")))))) + + (target (@ (name "jar") + (depends "compile")) + (mkdir (@ (dir "${jar.dir}"))) + ;; We cannot use the simpler "jar" task here, because + ;; there is no way to disable generation of a + ;; manifest. We do not include a generated manifest + ;; to ensure determinism, because we cannot easily + ;; reset the ctime/mtime before creating the archive. + (exec (@ (executable "jar")) + (arg (@ (line ,(string-append "-Mcf ${jar.dir}/" jar-name + " -C ${classes.dir} .")))))) + + (target (@ (name "install")) + (copy (@ (todir "${dist.dir}")) + (fileset (@ (dir "${jar.dir}")) + (include (@ (name "**/*.jar"))))))) + port))) + (utime "build.xml" 0 0) + #t) + +(define (generate-classpath inputs) + "Return a colon-separated string of full paths to jar files found among the +INPUTS." + (string-join + (apply append (map (match-lambda + ((_ . dir) + (find-files dir "\\.*jar$"))) + inputs)) ":")) + +(define* (configure #:key inputs outputs (jar-name #f) + #:allow-other-keys) + (when jar-name + (default-build.xml jar-name + (string-append (assoc-ref outputs "out") + "/share/java"))) + (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) + (setenv "CLASSPATH" (generate-classpath inputs))) + +(define* (build #:key (make-flags '()) (build-target "jar") + #:allow-other-keys) + (zero? (apply system* `("ant" ,build-target ,@make-flags)))) + +(define* (strip-jar-timestamps #:key outputs + #:allow-other-keys) + "Unpack all jar archives, reset the timestamp of all contained files, and +repack them. This is necessary to ensure that archives are reproducible." + (define (repack-archive jar) + (format #t "repacking ~a\n" jar) + (let ((dir (mkdtemp! "jar-contents.XXXXXX"))) + (and (with-directory-excursion dir + (zero? (system* "jar" "xf" jar))) + ;; The manifest file contains timestamps + (for-each delete-file (find-files dir "MANIFEST.MF")) + (delete-file jar) + ;; XXX: copied from (gnu build install) + (for-each (lambda (file) + (let ((s (lstat file))) + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files dir #:directories? #t)) + (unless (zero? (system* "jar" "-Mcf" jar "-C" dir ".")) + (error "'jar' failed")) + (utime jar 0 0) + #t))) + + (every (match-lambda + ((output . directory) + (every repack-archive (find-files directory "\\.jar$")))) + outputs)) + +(define* (check #:key target (make-flags '()) (tests? (not target)) + (test-target "check") + #:allow-other-keys) + (if tests? + (zero? (apply system* `("ant" ,test-target ,@make-flags))) + (begin + (format #t "test suite not run~%") + #t))) + +(define* (install #:key (make-flags '()) #:allow-other-keys) + (zero? (apply system* `("ant" "install" ,@make-flags)))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install 'strip-jar-timestamps strip-jar-timestamps))) + +(define* (ant-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Java package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; ant-build-system.scm ends here diff --git a/guix/build/download.scm b/guix/build/download.scm index 8843804c40..0568800d7f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> ;;; @@ -34,6 +34,7 @@ #:use-module (ice-9 format) #:export (open-socket-for-uri open-connection-for-uri + close-connection resolve-uri-reference maybe-expand-mirrors url-fetch @@ -236,11 +237,14 @@ abbreviation of URI showing the scheme, host, and basename of the file." (module-autoload! (current-module) '(gnutls) '(make-session connection-end/client)) -(define add-weak-reference - (let ((table (make-weak-key-hash-table))) - (lambda (from to) - "Hold a weak reference from FROM to TO." - (hashq-set! table from to)))) +(define %tls-ports + ;; Mapping of session record ports to the underlying file port. + (make-weak-key-hash-table)) + +(define (register-tls-record-port record-port port) + "Hold a weak reference from RECORD-PORT to PORT, where RECORD-PORT is a TLS +session record port using PORT as its underlying communication port." + (hashq-set! %tls-ports record-port port)) (define (tls-wrap port server) "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS @@ -275,7 +279,7 @@ host name without trailing dot." ;; closed when PORT is GC'd. If we used `port->fdes', it would instead ;; never be closed. So we use `fileno', but keep a weak reference to ;; PORT, so the file descriptor gets closed when RECORD is GC'd. - (add-weak-reference record port) + (register-tls-record-port record port) record))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) @@ -337,7 +341,8 @@ ETIMEDOUT error is raised." (loop (cdr addresses)))))))) (define* (open-connection-for-uri uri #:key timeout) - "Like 'open-socket-for-uri', but also handle HTTPS connections." + "Like 'open-socket-for-uri', but also handle HTTPS connections. The +resulting port must be closed with 'close-connection'." (define https? (eq? 'https (uri-scheme uri))) @@ -367,6 +372,17 @@ ETIMEDOUT error is raised." (tls-wrap s (uri-host uri)) s))))) +(define (close-connection port) + "Like 'close-port', but (1) idempotent, and (2) also closes the underlying +port if PORT is a TLS session record port." + ;; FIXME: This is a partial workaround for <http://bugs.gnu.org/20145>, + ;; because 'http-fetch' & co. may return a chunked input port whose 'close' + ;; method calls 'close-port', not 'close-connection'. + (unless (port-closed? port) + (close-port port)) + (and=> (hashq-ref %tls-ports port) + close-connection)) + ;; XXX: This is an awful hack to make sure the (set-port-encoding! p ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap ;; where iconv is not available. diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 0a9cd3260c..b216e6c0d7 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,6 +118,11 @@ file name pairs." (else (error "unsupported file type" stat))))) + ;; XXX: Work around occasional "suspicious ownership or permission" daemon + ;; errors that arise when we create the top-level /gnu/store/… directory as + ;; #o777. + (umask #o022) + (n-par-for-each (parallel-job-count) rewrite-leaf (find-files directory))) diff --git a/guix/cve.scm b/guix/cve.scm index a7b0bde6dc..8e76f42f0d 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,29 +49,45 @@ (id vulnerability-id) (packages vulnerability-packages)) -(define %cve-feed-uri +(define %now + (current-date)) +(define %current-year + (date-year %now)) +(define %past-year + (- %current-year 1)) + +(define (yearly-feed-uri year) + "Return the URI for the CVE feed for YEAR." (string->uri - "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-Modified.xml.gz")) + (string-append "https://static.nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-" + (number->string year) ".xml.gz"))) -(define %ttl +(define %current-year-ttl ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are ;; updated "approximately every two hours." (* 3600 3)) -(define (call-with-cve-port proc) +(define %past-year-ttl + ;; Update the previous year's database more and more infrequently. + (* 3600 24 2 (date-month %now))) + +(define (call-with-cve-port uri ttl proc) "Pass PROC an input port from which to read the CVE stream." - (let ((port (http-fetch/cached %cve-feed-uri #:ttl %ttl))) + (let ((port (http-fetch/cached uri #:ttl ttl))) (dynamic-wind (const #t) (lambda () (call-with-decompressed-port 'gzip port - proc)) + (lambda (port) + (setvbuf port _IOFBF 65536) + (proc port)))) (lambda () (close-port port))))) (define %cpe-package-rx - ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION". - (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)")) + ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes + ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL". + (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)((:.+)?)")) (define (cpe->package-name cpe) "Converts the Common Platform Enumeration (CPE) string CPE to a package @@ -80,7 +96,13 @@ CPE string." (and=> (regexp-exec %cpe-package-rx (string-trim-both cpe)) (lambda (matches) (cons (match:substring matches 2) - (match:substring matches 3))))) + (string-append (match:substring matches 3) + (match (match:substring matches 4) + ("" "") + (patch-level + ;; Drop the colon from things like + ;; "cpe:/a:openbsd:openssh:6.8:p1". + (string-drop patch-level 1)))))))) (define %parse-vulnerability-feed ;; Parse the XML vulnerability feed from @@ -135,12 +157,19 @@ vulnerability objects." (define (current-vulnerabilities) "Return the current list of Common Vulnerabilities and Exposures (CVE) as published by the US NIST." - (call-with-cve-port - (lambda (port) - ;; XXX: The SSAX "error port" is used to send pointless warnings such as - ;; "warning: Skipping PI". Turn that off. - (parameterize ((current-ssax-error-port (%make-void-port "w"))) - (xml->vulnerabilities port))))) + (define (read-vulnerabilities uri ttl) + (call-with-cve-port uri ttl + (lambda (port) + ;; XXX: The SSAX "error port" is used to send pointless warnings such as + ;; "warning: Skipping PI". Turn that off. + (parameterize ((current-ssax-error-port (%make-void-port "w"))) + (xml->vulnerabilities port))))) + + (append-map read-vulnerabilities + (list (yearly-feed-uri %past-year) + (yearly-feed-uri %current-year)) + (list %past-year-ttl + %current-year-ttl))) (define (vulnerabilities->lookup-proc vulnerabilities) "Return a lookup procedure built from VULNERABILITIES that takes a package @@ -174,4 +203,9 @@ a list of vulnerabilities affection the given package version." '() package table))) + +;;; Local Variables: +;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2) +;;; End: + ;;; cve.scm ends here diff --git a/guix/derivations.scm b/guix/derivations.scm index 1164774009..f24e3c6f92 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -695,7 +695,8 @@ HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) hash hash-algo recursive? - references-graphs allowed-references + references-graphs + allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t)) "Build a derivation with the given arguments, and return the resulting @@ -710,7 +711,8 @@ pairs. In that case, the reference graph of each store path is exported in the build environment in the corresponding file, in a simple text format. When ALLOWED-REFERENCES is true, it must be a list of store items or outputs -that the derivation's output may refer to. +that the derivation's outputs may refer to. Likewise, DISALLOWED-REFERENCES, +if true, must be a list of things the outputs may not refer to. When LEAKED-ENV-VARS is true, it must be a list of strings denoting environment variables that are allowed to \"leak\" from the daemon's @@ -768,6 +770,10 @@ output should not be used." `(("allowedReferences" . ,(string-join allowed-references))) '()) + ,@(if disallowed-references + `(("disallowedReferences" + . ,(string-join disallowed-references))) + '()) ,@(if leaked-env-vars `(("impureEnvVars" . ,(string-join leaked-env-vars))) @@ -1112,6 +1118,7 @@ they can refer to each other." guile-for-build references-graphs allowed-references + disallowed-references local-build? (substitutable? #t)) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) @@ -1132,7 +1139,7 @@ EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is omitted or is #f, the value of the `%guile-for-build' fluid is used instead. See the `derivation' procedure for the meaning of REFERENCES-GRAPHS, -ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." +ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1258,6 +1265,7 @@ ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." #:outputs outputs #:references-graphs references-graphs #:allowed-references allowed-references + #:disallowed-references disallowed-references #:local-build? local-build? #:substitutable? substitutable?))) diff --git a/guix/gexp.scm b/guix/gexp.scm index 87bc316f97..7cbc79c31c 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -463,7 +463,7 @@ names and file names suitable for the #:allowed-references argument to (guile-for-build (%guile-for-build)) (graft? (%graft?)) references-graphs - allowed-references + allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) (script-name (string-append name "-builder"))) @@ -497,6 +497,8 @@ text format. ALLOWED-REFERENCES must be either #f or a list of output names and packages. In the latter case, the list denotes store items that the result is allowed to refer to. Any reference to another store item will lead to a build error. +Similarly for DISALLOWED-REFERENCES, which can list items that must not be +referenced by the outputs. The other arguments are as for 'derivation'." (define %modules modules) @@ -557,6 +559,11 @@ The other arguments are as for 'derivation'." #:system system #:target target) (return #f))) + (disallowed (if disallowed-references + (lower-references disallowed-references + #:system system + #:target target) + (return #f))) (guile (if guile-for-build (return guile-for-build) (default-guile-derivation system)))) @@ -585,6 +592,7 @@ The other arguments are as for 'derivation'." #:hash hash #:hash-algo hash-algo #:recursive? recursive? #:references-graphs (and=> graphs graphs-file-names) #:allowed-references allowed + #:disallowed-references disallowed #:leaked-env-vars leaked-env-vars #:local-build? local-build? #:substitutable? substitutable?)))) diff --git a/guix/grafts.scm b/guix/grafts.scm index a1f7d8801a..6bec999ad2 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -17,13 +17,18 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix grafts) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix records) #:use-module (guix derivations) #:use-module ((guix utils) #:select (%current-system)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (graft? graft graft-origin @@ -32,6 +37,7 @@ graft-replacement-output graft-derivation + graft-derivation/shallow %graft? set-grafting)) @@ -61,13 +67,22 @@ (set-record-type-printer! <graft> write-graft) -(define* (graft-derivation store drv grafts - #:key - (name (derivation-name drv)) - (guile (%guile-for-build)) - (system (%current-system))) +(define (graft-origin-file-name graft) + "Return the output file name of the origin of GRAFT." + (match graft + (($ <graft> (? derivation? origin) output) + (derivation->output-path origin output)) + (($ <graft> (? string? item)) + item))) + +(define* (graft-derivation/shallow store drv grafts + #:key + (name (derivation-name drv)) + (guile (%guile-for-build)) + (system (%current-system))) "Return a derivation called NAME, based on DRV but with all the GRAFTS -applied." +applied. This procedure performs \"shallow\" grafting in that GRAFTS are not +recursively applied to dependencies of DRV." ;; XXX: Someday rewrite using gexps. (define mapping ;; List of store item pairs. @@ -82,14 +97,13 @@ applied." grafts)) (define outputs - (match (derivation-outputs drv) - (((names . outputs) ...) - (map derivation-output-path outputs)))) + (map (match-lambda + ((name . output) + (cons name (derivation-output-path output)))) + (derivation-outputs drv))) (define output-names - (match (derivation-outputs drv) - (((names . outputs) ...) - names))) + (derivation-output-names drv)) (define build `(begin @@ -97,14 +111,20 @@ applied." (guix build utils) (ice-9 match)) - (let ((mapping ',mapping)) + (let* ((old-outputs ',outputs) + (mapping (append ',mapping + (map (match-lambda + ((name . file) + (cons (assoc-ref old-outputs name) + file))) + %outputs)))) (for-each (lambda (input output) (format #t "grafting '~a' -> '~a'...~%" input output) (force-output) - (rewrite-directory input output - `((,input . ,output) - ,@mapping))) - ',outputs + (rewrite-directory input output mapping)) + (match old-outputs + (((names . files) ...) + files)) (match %outputs (((names . files) ...) files)))))) @@ -128,6 +148,144 @@ applied." (map add-label targets))) #:outputs output-names #:local-build? #t))))) +(define (item->deriver store item) + "Return two values: the derivation that led to ITEM (a store item), and the +name of the output of that derivation ITEM corresponds to (for example +\"out\"). When ITEM has no deriver, for instance because it is a plain file, +#f and #f are returned." + (match (valid-derivers store item) + (() ;ITEM is a plain file + (values #f #f)) + ((drv-file _ ...) + (let ((drv (call-with-input-file drv-file read-derivation))) + (values drv + (any (match-lambda + ((name . path) + (and (string=? item path) name))) + (derivation->output-paths drv))))))) + +(define (non-self-references references drv outputs) + "Return the list of references of the OUTPUTS of DRV, excluding self +references. Call REFERENCES to get the list of references." + (let ((refs (append-map (compose references + (cut derivation->output-path drv <>)) + outputs)) + (self (match (derivation->output-paths drv) + (((names . items) ...) + items)))) + (remove (cut member <> self) refs))) + +(define (references-oracle store drv) + "Return a one-argument procedure that, when passed the file name of DRV's +outputs or their dependencies, returns the list of references of that item. +Use either local info or substitute info; build DRV if no information is +available." + (define (output-paths drv) + (match (derivation->output-paths drv) + (((names . items) ...) + items))) + + (define (references* items) + (guard (c ((nix-protocol-error? c) + ;; As a last resort, build DRV and query the references of the + ;; build result. + + ;; Warm up the narinfo cache, otherwise each derivation build + ;; will result in one HTTP request to get one narinfo, which is + ;; much less efficient than fetching them all upfront. + (substitution-oracle store (list drv)) + + (and (build-derivations store (list drv)) + (map (cut references store <>) items)))) + (references/substitutes store items))) + + (let loop ((items (output-paths drv)) + (result vlist-null)) + (match items + (() + (lambda (item) + (match (vhash-assoc item result) + ((_ . refs) refs) + (#f #f)))) + (_ + (let* ((refs (references* items)) + (result (fold vhash-cons result items refs))) + (loop (remove (cut vhash-assoc <> result) + (delete-duplicates (concatenate refs) string=?)) + result)))))) + +(define* (cumulative-grafts store drv grafts + references + #:key + (outputs (derivation-output-names drv)) + (guile (%guile-for-build)) + (system (%current-system))) + "Augment GRAFTS with additional grafts resulting from the application of +GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure +that returns the list of references of the store item it is given. Return the +resulting list of grafts. + +This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping +derivations to the corresponding set of grafts." + (define (dependency-grafts item) + (let-values (((drv output) (item->deriver store item))) + (if drv + (cumulative-grafts store drv grafts references + #:outputs (list output) + #:guile guile + #:system system) + (state-return grafts)))) + + (define (return/cache cache value) + (mbegin %store-monad + (set-current-state (vhash-consq drv value cache)) + (return value))) + + (mlet %state-monad ((cache (current-state))) + (match (vhash-assq drv cache) + ((_ . grafts) ;hit + (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)) + (cache (current-state))) + (let* ((grafts (delete-duplicates (concatenate grafts) equal?)) + (origins (map graft-origin-file-name grafts))) + (if (find (cut member <> deps) origins) + (let* ((new (graft-derivation/shallow store drv grafts + #:guile guile + #:system system)) + (grafts (cons (graft (origin drv) (replacement new)) + grafts))) + (return/cache cache grafts)) + (return/cache cache grafts)))))))))) + +(define* (graft-derivation store drv grafts + #:key (guile (%guile-for-build)) + (system (%current-system))) + "Applied GRAFTS to DRV and all its dependencies, recursively. That is, if +GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft +DRV itself to refer to those grafted dependencies." + + ;; First, pre-compute the dependency tree of the outputs of DRV. Do this + ;; upfront to have as much parallelism as possible when querying substitute + ;; info or when building DRV. + (define references + (references-oracle store drv)) + + (match (run-with-state + (cumulative-grafts store drv grafts references + #:guile guile #:system system) + vlist-null) ;the initial cache + ((first . rest) + ;; If FIRST is not a graft for DRV, it means that GRAFTS are not + ;; applicable to DRV and nothing needs to be done. + (if (equal? drv (graft-origin first)) + (graft-replacement first) + drv)))) ;; The following might feel more at home in (guix packages) but since (guix diff --git a/guix/http-client.scm b/guix/http-client.scm index 2161856c63..97a1e26d3e 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -222,11 +222,14 @@ or if EOF is reached." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) -(define* (http-fetch uri #:key port (text? #f) (buffered? #t)) +(define* (http-fetch uri #:key port (text? #f) (buffered? #t) + keep-alive?) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an -unbuffered port, suitable for use in `filtered-port'. +unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is +true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be +reused for future HTTP requests. Raise an '&http-get-error' condition if downloading fails." (let loop ((uri (if (string? uri) @@ -240,14 +243,16 @@ Raise an '&http-get-error' condition if downloading fails." (base64-encode (string->utf8 str)))))) (_ '())))) - (unless buffered? + (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF)) (let*-values (((resp data) ;; Try hard to use the API du jour to get an input port. (if (guile-version>? "2.0.7") (http-get uri #:streaming? #t #:port port + #:keep-alive? #t #:headers auth-header) ; 2.0.9+ (http-get* uri #:decode-body? text? ; 2.0.7 + #:keep-alive? #t #:port port #:headers auth-header))) ((code) (response-code resp))) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index d54bb9fbba..8ae4948147 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Cyril Roelandt <tipecaml@gmail.com> -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -194,7 +194,15 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (version ,version) (source (origin (method url-fetch) - (uri (pypi-uri ,name version)) + + ;; Sometimes 'pypi-uri' doesn't quite work due to mixed + ;; cases in NAME, for instance, as is the case with + ;; "uwsgi". In that case, fall back to a full URL. + (uri ,(if (equal? (pypi-uri name version) source-url) + `(pypi-uri ,name version) + `(string-append + ,@(factorize-uri source-url version)))) + (sha256 (base32 ,(guix-hash-url temp))))) diff --git a/guix/import/snix.scm b/guix/import/snix.scm index 033b7165d3..bc75cbfda5 100644 --- a/guix/import/snix.scm +++ b/guix/import/snix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +31,13 @@ #:use-module (srfi srfi-37) #:use-module (system foreign) #:use-module (rnrs bytevectors) - #:use-module (guix utils) + + ;; Use the 'package-name->name+version' procedure that works with + ;; hyphen-separate name/version, not the one that works with '@'-separated + ;; name/version. Subtle! + #:use-module ((guix utils) #:hide (package-name->name+version)) + #:use-module ((guix build utils) #:select (package-name->name+version)) + #:use-module (guix import utils) #:use-module (guix base32) #:use-module (guix config) diff --git a/guix/licenses.scm b/guix/licenses.scm index 61e679358a..71c0736223 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -28,7 +28,7 @@ #:use-module (srfi srfi-9) #:export (license? license-name license-uri license-comment agpl3 agpl3+ - asl2.0 + asl1.1 asl2.0 boost1.0 bsd-2 bsd-3 bsd-4 non-copyleft @@ -100,6 +100,11 @@ "https://gnu.org/licenses/agpl.html" "https://gnu.org/licenses/why-affero-gpl.html")) +(define asl1.1 + (license "ASL 1.1" + "http://directory.fsf.org/wiki/License:Apache1.1" + "https://www.gnu.org/licenses/license-list#apache1")) + (define asl2.0 (license "ASL 2.0" "http://directory.fsf.org/wiki/License:Apache2.0" diff --git a/guix/packages.scm b/guix/packages.scm index f6afaeb510..d62d1f3343 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -30,6 +30,7 @@ #:use-module (guix build-system) #:use-module (guix search-paths) #:use-module (guix gexp) + #:use-module (guix sets) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) @@ -726,8 +727,8 @@ dependencies are known to build on SYSTEM." ;; Package to derivation-path mapping. (make-weak-key-hash-table 100)) -(define (cache package system thunk) - "Memoize the return values of THUNK as the derivation of PACKAGE on +(define (cache! cache package system thunk) + "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on SYSTEM." ;; FIXME: This memoization should be associated with the open store, because ;; otherwise it breaks when switching to a different store. @@ -735,26 +736,29 @@ SYSTEM." ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the ;; same value for all structs (as of Guile 2.0.6), and because pointer ;; equality is sufficient in practice. - (hashq-set! %derivation-cache package + (hashq-set! cache package `((,system ,@vals) - ,@(or (hashq-ref %derivation-cache package) - '()))) + ,@(or (hashq-ref cache package) '()))) (apply values vals))) -(define-syntax-rule (cached package system body ...) - "Memoize the result of BODY for the arguments PACKAGE and SYSTEM. +(define-syntax cached + (syntax-rules (=>) + "Memoize the result of BODY for the arguments PACKAGE and SYSTEM. Return the cached result when available." - (let ((thunk (lambda () body ...)) - (key system)) - (match (hashq-ref %derivation-cache package) - ((alist (... ...)) - (match (assoc-ref alist key) - ((vals (... ...)) - (apply values vals)) + ((_ (=> cache) package system body ...) + (let ((thunk (lambda () body ...)) + (key system)) + (match (hashq-ref cache package) + ((alist (... ...)) + (match (assoc-ref alist key) + ((vals (... ...)) + (apply values vals)) + (#f + (cache! cache package key thunk)))) (#f - (cache package key thunk)))) - (#f - (cache package key thunk))))) + (cache! cache package key thunk))))) + ((_ package system body ...) + (cached (=> %derivation-cache) package system body ...)))) (define* (expand-input store package input system #:optional cross-system) "Expand INPUT, an input tuple, such that it contains only references to @@ -794,67 +798,77 @@ information in exceptions." (package package) (input x))))))) +(define %bag-cache + ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags. + ;; It significantly speeds things up when doing repeated calls to + ;; 'package->bag' as is the case when building a profile. + (make-weak-key-hash-table 200)) + (define* (package->bag package #:optional (system (%current-system)) (target (%current-target-system)) #:key (graft? (%graft?))) "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, and return it." - ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field - ;; values can refer to it. - (parameterize ((%current-system system) - (%current-target-system target)) - (match (if graft? - (or (package-replacement package) package) - package) - (($ <package> name version source build-system - args inputs propagated-inputs native-inputs self-native-input? - outputs) - (or (make-bag build-system (string-append name "-" version) - #:system system - #:target target - #:source source - #:inputs (append (inputs) - (propagated-inputs)) - #:outputs outputs - #:native-inputs `(,@(if (and target self-native-input?) - `(("self" ,package)) - '()) - ,@(native-inputs)) - #:arguments (args)) - (raise (if target - (condition - (&package-cross-build-system-error - (package package))) - (condition - (&package-error - (package package)))))))))) + (cached (=> %bag-cache) + package (list system target graft?) + ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked + ;; field values can refer to it. + (parameterize ((%current-system system) + (%current-target-system target)) + (match (if graft? + (or (package-replacement package) package) + package) + (($ <package> name version source build-system + args inputs propagated-inputs native-inputs + self-native-input? outputs) + (or (make-bag build-system (string-append name "-" version) + #:system system + #:target target + #:source source + #:inputs (append (inputs) + (propagated-inputs)) + #:outputs outputs + #:native-inputs `(,@(if (and target + self-native-input?) + `(("self" ,package)) + '()) + ,@(native-inputs)) + #:arguments (args)) + (raise (if target + (condition + (&package-cross-build-system-error + (package package))) + (condition + (&package-error + (package package))))))))))) + +(define %graft-cache + ;; 'eq?' cache mapping package objects to a graft corresponding to their + ;; replacement package. + (make-weak-key-hash-table 200)) (define (input-graft store system) - "Return a procedure that, given an input referring to a package with a -graft, returns a pair with the original derivation and the graft's derivation, -and returns #f for other inputs." + "Return a procedure that, given a package with a graft, returns a graft, and +#f otherwise." (match-lambda - ((label (? package? package) sub-drv ...) - (let ((replacement (package-replacement package))) - (and replacement - (let ((orig (package-derivation store package system - #:graft? #f)) - (new (package-derivation store replacement system))) - (graft - (origin orig) - (replacement new) - (origin-output (match sub-drv - (() "out") - ((output) output))) - (replacement-output origin-output)))))) - (x - #f))) + ((? package? package) + (let ((replacement (package-replacement package))) + (and replacement + (cached (=> %graft-cache) package system + (let ((orig (package-derivation store package system + #:graft? #f)) + (new (package-derivation store replacement system))) + (graft + (origin orig) + (replacement new))))))) + (x + #f))) (define (input-cross-graft store target system) "Same as 'input-graft', but for cross-compilation inputs." (match-lambda - ((label (? package? package) sub-drv ...) + ((? package? package) (let ((replacement (package-replacement package))) (and replacement (let ((orig (package-cross-derivation store package target system @@ -863,34 +877,80 @@ and returns #f for other inputs." target system))) (graft (origin orig) - (replacement new) - (origin-output (match sub-drv - (() "out") - ((output) output))) - (replacement-output origin-output)))))) + (replacement new)))))) (_ #f))) -(define* (bag-grafts store bag) - "Return the list of grafts applicable to BAG. Each graft is a <graft> -record." - (let ((target (bag-target bag)) - (system (bag-system bag))) - (define native-grafts - (filter-map (input-graft store system) - (append (bag-transitive-build-inputs bag) - (bag-transitive-target-inputs bag) - (if target - '() - (bag-transitive-host-inputs bag))))) - - (define target-grafts - (if target - (filter-map (input-cross-graft store target system) - (bag-transitive-host-inputs bag)) - '())) +(define* (fold-bag-dependencies proc seed bag + #:key (native? #t)) + "Fold PROC over the packages BAG depends on. Each package is visited only +once, in depth-first order. If NATIVE? is true, restrict to native +dependencies; otherwise, restrict to target dependencies." + (define nodes + (match (if native? + (append (bag-build-inputs bag) + (bag-target-inputs bag) + (if (bag-target bag) + '() + (bag-host-inputs bag))) + (bag-host-inputs bag)) + (((labels things _ ...) ...) + things))) + + (let loop ((nodes nodes) + (result seed) + (visited (setq))) + (match nodes + (() + result) + (((? package? head) . tail) + (if (set-contains? visited head) + (loop tail result visited) + (let ((inputs (bag-direct-inputs (package->bag head)))) + (loop (match inputs + (((labels things _ ...) ...) + (append things tail))) + (proc head result) + (set-insert head visited))))) + ((head . tail) + (loop tail result visited))))) - (append native-grafts target-grafts))) +(define* (bag-grafts store bag) + "Return the list of grafts potentially applicable to BAG. Potentially +applicable grafts are collected by looking at direct or indirect dependencies +of BAG that have a 'replacement'. Whether a graft is actually applicable +depends on whether the outputs of BAG depend on the items the grafts refer +to (see 'graft-derivation'.)" + (define system (bag-system bag)) + (define target (bag-target bag)) + + (define native-grafts + (let ((->graft (input-graft store system))) + (fold-bag-dependencies (lambda (package grafts) + (match (->graft package) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag))) + + (define target-grafts + (if target + (let ((->graft (input-cross-graft store target system))) + (fold-bag-dependencies (lambda (package grafts) + (match (->graft package) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag + #:native? #f)) + '())) + + ;; We can end up with several identical grafts if we stumble upon packages + ;; that are not 'eq?' but map to the same derivation (this can happen when + ;; using things like 'package-with-explicit-inputs'.) Hence the + ;; 'delete-duplicates' call. + (delete-duplicates + (append native-grafts target-grafts))) (define* (package-grafts store package #:optional (system (%current-system)) @@ -985,6 +1045,9 @@ This is an internal procedure." (grafts (let ((guile (package-derivation store (default-guile) system #:graft? #f))) + ;; TODO: As an optimization, we can simply graft the tip + ;; of the derivation graph since 'graft-derivation' + ;; recurses anyway. (graft-derivation store drv grafts #:system system #:guile guile)))) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 1a941d1a73..3fb210ee91 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix monads) @@ -50,6 +51,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -318,27 +320,28 @@ the input port." ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) (let ((opts (parse-command-line args %options (list %default-options)))) - (cond ((assoc-ref opts 'generate-key) - => - generate-key-pair) - ((assoc-ref opts 'authorize) - (authorize-key)) - (else - (let ((store (open-connection))) - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (_ "either '--export' or '--import' \ -must be specified~%"))))))))))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (cond ((assoc-ref opts 'generate-key) + => + generate-key-pair) + ((assoc-ref opts 'authorize) + (authorize-key)) + (else + (with-store store + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (_ "either '--export' or '--import' \ +must be specified~%")))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8725ddad88..b25bf50d2b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -296,6 +296,8 @@ options handled by 'set-build-options-from-command-line', and listed in --substitute-urls=URLS fetch substitute from URLS if they are authorized")) (display (_ " + --no-grafts do not graft packages")) + (display (_ " --no-build-hook do not attempt to offload builds via the build hook")) (display (_ " --max-silent-time=SECONDS @@ -379,6 +381,12 @@ options handled by 'set-build-options-from-command-line', and listed in (string-tokenize arg) (alist-delete 'substitute-urls result)) rest))) + (option '("no-grafts") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'graft? #f + (alist-delete 'graft? result eq?)) + rest))) (option '("no-build-hook") #f #f (lambda (opt name arg result . rest) (apply values @@ -452,8 +460,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) (display (_ " - --no-grafts do not graft packages")) - (display (_ " -d, --derivations return the derivation paths of the given packages")) (display (_ " --check rebuild items to check for non-determinism issues")) @@ -461,6 +467,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (_ " + -q, --quiet do not show the build log")) + (display (_ " --log-file return the log file names for the given derivations")) (newline) (show-build-options-help) @@ -528,13 +536,12 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\q "quiet") #f #f + (lambda (opt name arg result) + (alist-cons 'quiet? #t result))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) - (option '("no-grafts") #f #f - (lambda (opt name arg result) - (alist-cons 'graft? #f - (alist-delete 'graft? result eq?)))) (append %transformation-options %standard-build-options))) @@ -590,15 +597,16 @@ build." (parameterize ((%graft? graft?)) (append-map (match-lambda ((? package? p) - (match src - (#f - (list (package->derivation store p system))) - (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) - (proc - (map (cut package-source-derivation store <>) - (proc p))))) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (let ((s (package-source p))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) ((? derivation? drv) (list drv)) ((? procedure? proc) @@ -631,55 +639,66 @@ needed." ;;; (define (guix-build . args) + (define opts + (parse-command-line args %options + (list %default-options))) + + (define quiet? + (assoc-ref opts 'quiet?)) + (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let* ((opts (parse-command-line args %options - (list %default-options))) - (store (open-connection)) - (mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - + (with-store store + ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (unless (assoc-ref opts 'log-file?) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))) + + (parameterize ((current-build-output-port (if quiet? + (%make-void-port "w") + (current-error-port)))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0e462de4bf..b122b4cd40 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -176,9 +177,9 @@ COMMAND or an interactive shell in that environment.\n")) (show-bug-report-information)) (define %default-options - ;; Default to opening a new shell. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -525,7 +526,8 @@ message if any test fails." (with-store store ;; Use the bootstrap Guile when requested. - (parameterize ((%guile-for-build + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation store (if bootstrap? diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index dcc4701779..b0d7c08582 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -19,6 +19,7 @@ (define-module (guix scripts graph) #:use-module (guix ui) #:use-module (guix graph) + #:use-module (guix grafts) #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) @@ -340,8 +341,12 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (define (guix-graph . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) + (let* ((opts (args-fold* args %options + (lambda (opt name arg . rest) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (type (assoc-ref opts 'node-type)) (packages (filter-map (match-lambda (('argument . spec) @@ -352,7 +357,9 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) opts))) (with-store store (run-with-store store - (mlet %store-monad ((nodes (mapm %store-monad + ;; XXX: Since grafting can trigger unsolicited builds, disable it. + (mlet %store-monad ((_ (set-grafting #f)) + (nodes (mapm %store-monad (node-type-convert type) packages))) (export-graph (concatenate nodes) diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 4e84278a78..f2c20026b6 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -46,7 +46,7 @@ (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME -includes a suffix constituted by a dash followed by a numerical version (as +includes a suffix constituted by a at-sign followed by a numerical version (as used with Guix packages), then a definition for the specified version of the package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e729398742..27b9e155ec 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -20,10 +20,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts lint) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) + #:use-module (guix http-client) #:use-module (guix packages) #:use-module (guix licenses) #:use-module (guix records) @@ -40,7 +41,8 @@ #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors - open-connection-for-uri)) + open-connection-for-uri + close-connection)) #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) @@ -295,7 +297,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (force-output port) (read-response port)) (lambda () - (close port)))) + (close-connection port)))) (case (response-code response) ((301 302 307) @@ -551,7 +553,15 @@ descriptions maintained upstream." (format #f (_ "failed to create derivation: ~a") (condition-message c))))) (with-store store - (package-derivation store package)))) + ;; Disable grafts since it can entail rebuilds. + (package-derivation store package #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement #:graft? #f)))))) (lambda args (emit-warning package (format #f (_ "failed to create derivation: ~s~%") @@ -585,18 +595,30 @@ Common Platform Enumeration (CPE) name." ;; TODO: Add more. (_ name))) +(define (current-vulnerabilities*) + "Like 'current-vulnerabilities', but return the empty list upon networking +or HTTP errors. This allows network-less operation and makes problems with +the NIST server non-fatal.." + (guard (c ((http-get-error? c) + (warning (_ "failed to retrieve CVE vulnerabilities \ +from ~s: ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '())) + (catch 'getaddrinfo-error + (lambda () + (current-vulnerabilities)) + (lambda (key errcode) + (warning (_ "failed to lookup NIST host: ~a~%") + (gai-strerror errcode)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '())))) + (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc - ;; Catch networking errors to allow network-less - ;; operation. - (catch 'getaddrinfo-error - (lambda () - (current-vulnerabilities)) - (lambda (key errcode) - (warn (_ "failed to lookup NIST host: ~a~%") - (gai-strerror errcode)) - (warn (_ "assuming no CVE vulnerabilities~%")) - '())))))) + (current-vulnerabilities*))))) (lambda (package) "Return a list of vulnerabilities affecting PACKAGE." ((force lookup) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f65834386b..1d88b33996 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -22,6 +22,7 @@ (define-module (guix scripts package) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -319,6 +320,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." ;; Alist of default option values. `((max-silent-time . 3600) (verbosity . 0) + (graft? . #t) (substitutes? . #t))) (define (show-help) @@ -837,7 +839,8 @@ processed, #f otherwise." #:argument-handler handle-argument))) (with-error-handling (or (process-query opts) - (parameterize ((%store (open-connection))) + (parameterize ((%store (open-connection)) + (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index e999cce1fd..8f0cb7decd 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages) @@ -274,19 +275,23 @@ Report the size of PACKAGE and its dependencies.\n")) (leave (_ "missing store item argument\n"))) ((file) (leave-on-EPIPE - (with-store store - (set-build-options store - #:use-substitutes? #t - #:substitute-urls urls) + ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted + ;; packages, and (2) they do not make any difference on the + ;; resulting size. + (parameterize ((%graft? #f)) + (with-store store + (set-build-options store + #:use-substitutes? #t + #:substitute-urls urls) - (run-with-store store - (mlet* %store-monad ((item (ensure-store-item file)) - (profile (store-profile item))) - (if map-file - (begin - (profile->page-map profile map-file) - (return #t)) - (display-profile* profile))) - #:system system)))) + (run-with-store store + (mlet* %store-monad ((item (ensure-store-item file)) + (profile (store-profile item))) + (if map-file + (begin + (profile->page-map profile map-file) + (return #t)) + (display-profile* profile))) + #:system system))))) ((files ...) (leave (_ "too many arguments\n"))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 01cc3f129e..4563f3df0f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -19,7 +19,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix records) @@ -32,6 +32,8 @@ #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (progress-proc uri-abbreviation + open-connection-for-uri + close-connection store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -49,6 +51,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (web uri) + #:use-module (web http) #:use-module (web request) #:use-module (web response) #:use-module (guix http-client) @@ -106,15 +109,18 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. This is a reasonable default value (corresponds to the TTL for - ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to - ;; state what their TTL is in /nix-cache-info. (XXX) + ;; valid for substitute servers that do not advertise a TTL via the + ;; 'Cache-Control' response header. (* 36 3600)) (define %narinfo-negative-ttl - ;; Likewise, but for negative lookups---i.e., cached lookup failures. + ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). (* 3 3600)) +(define %narinfo-transient-error-ttl + ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). + (* 10 60)) + (define %narinfo-expired-cache-entry-removal-delay ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) @@ -162,23 +168,20 @@ again." (sigaction SIGALRM SIG_DFL) (apply values result))))) -(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) +(define* (fetch uri #:key (buffered? #t) (timeout? #t)) "Return a binary input port to URI and the number of bytes it's expected to -provide. If QUIET-404? is true, HTTP 404 error conditions are passed through -to the caller without emitting an error message." +provide." (case (uri-scheme uri) ((file) (let ((port (open-file (uri-path uri) (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) - ((http) + ((http https) (guard (c ((http-get-error? c) - (let ((code (http-get-error-code c))) - (if (and (= code 404) quiet-404?) - (raise c) - (leave (_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - code (http-get-error-reason c)))))) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)))) ;; Test this with: ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: @@ -198,13 +201,16 @@ to the caller without emitting an error message." (unless (or (guile-version>? "2.0.9") (version>? (version) "2.0.9.39")) (when port - (close-port port)))) + (close-connection port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri)) - (unless buffered? + (set! port (open-connection-for-uri uri)) + (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) - (http-fetch uri #:text? #f #:port port)))))))) + (http-fetch uri #:text? #f #:port port)))))) + (else + (leave (_ "unsupported substitute URI scheme: ~a~%") + (uri->string uri))))) (define-record-type <cache-info> (%make-cache-info url store-directory wants-mass-query?) @@ -214,19 +220,46 @@ to the caller without emitting an error message." (wants-mass-query? cache-info-wants-mass-query?)) (define (download-cache-info url) - "Download the information for the cache at URL. Return a <cache-info> -object on success, or #f on failure." - (define (download url) - ;; Download the `nix-cache-info' from URL, and return its contents as an - ;; list of key/value pairs. - (and=> (false-if-exception (fetch (string->uri url))) - fields->alist)) - - (and=> (download (string-append url "/nix-cache-info")) - (lambda (properties) - (alist->record properties - (cut %make-cache-info url <...>) - '("StoreDir" "WantMassQuery"))))) + "Download the information for the cache at URL. On success, return a +<cache-info> object and a port on which to send further HTTP requests. On +failure, return #f and #f." + (define uri + (string->uri (string-append url "/nix-cache-info"))) + + (define (read-cache-info port) + (alist->record (fields->alist port) + (cut %make-cache-info url <...>) + '("StoreDir" "WantMassQuery"))) + + (catch #t + (lambda () + (case (uri-scheme uri) + ((file) + (values (call-with-input-file (uri-path uri) + read-cache-info) + #f)) + ((http https) + (let ((port (open-connection-for-uri uri + #:timeout %fetch-timeout))) + (guard (c ((http-get-error? c) + (warning (_ "while fetching '~a': ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (close-connection port) + (warning (_ "ignoring substitute server at '~s'~%") url) + (values #f #f))) + (values (read-cache-info (http-fetch uri + #:port port + #:keep-alive? #t)) + port)))))) + (lambda (key . args) + (case key + ((getaddrinfo-error system-error) + ;; Silently ignore the error: probably due to lack of network access. + (values #f #f)) + (else + (apply throw key args)))))) (define-record-type <narinfo> @@ -423,18 +456,18 @@ for PATH." (call-with-input-file cache-file (lambda (p) (match (read p) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value #f)) + ('date date) ('ttl _) ('value #f)) ;; A cached negative lookup. (if (obsolete? date now %narinfo-negative-ttl) (values #f #f) (values #t #f))) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value value)) + ('date date) ('ttl ttl) ('value value)) ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) + (if (obsolete? date now ttl) (values #f #f) (values #t (string->narinfo value cache-uri)))) (('narinfo ('version v) _ ...) @@ -442,16 +475,19 @@ for PATH." (lambda _ (values #f #f)))) -(define (cache-narinfo! cache-url path narinfo) - "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO -may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." +(define (cache-narinfo! cache-url path narinfo ttl) + "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the +given TTL (a number of seconds or #f). NARINFO may be #f, in which case it +indicates that PATH is unavailable at CACHE-URL." (define now (current-time time-monotonic)) (define (cache-entry cache-uri narinfo) - `(narinfo (version 1) + `(narinfo (version 2) (cache-uri ,cache-uri) (date ,(time-second now)) + (ttl ,(or ttl + (if narinfo %narinfo-ttl %narinfo-negative-ttl))) (value ,(and=> narinfo narinfo->string)))) (let ((file (narinfo-cache-file cache-url path))) @@ -475,20 +511,35 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-url proc seed requests) - "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +(define* (http-multiple-get base-uri proc seed requests + #:key port) + "Send all of REQUESTS to the server at BASE-URI. Call PROC for each response, passing it the request object, the response, a port from which to read the response body, and the previous result, starting with SEED, à la -'fold'. Return the final result." - (let connect ((requests requests) +'fold'. Return the final result. When PORT is specified, use it as the +initial connection on which HTTP requests are sent." + (let connect ((port port) + (requests requests) (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (open-socket-for-uri base-url))) + (let ((p (or port (open-connection-for-uri base-uri)))) + ;; For HTTPS, P is not a file port and does not support 'setvbuf'. + (when (file-port? p) + (setvbuf p _IOFBF (expt 2 16))) + ;; Send all of REQUESTS in a row. - (setvbuf p _IOFBF (expt 2 16)) - (for-each (cut write-request <> p) requests) - (force-output p) + ;; XXX: Do our own caching to work around inefficiencies when + ;; communicating over TLS: <http://bugs.gnu.org/22966>. + (let-values (((buffer get) (open-bytevector-output-port))) + ;; On Guile > 2.0.9, inherit the HTTP proxying property from P. + (when (module-variable (resolve-interface '(web http)) + 'http-proxy-port?) + (set-http-proxy-port?! buffer (http-proxy-port? p))) + + (for-each (cut write-request <> buffer) requests) + (put-bytevector p (get)) + (force-output p)) ;; Now start processing responses. (let loop ((requests requests) @@ -505,8 +556,8 @@ read the response body, and the previous result, starting with SEED, à la ;; Note that even upon "Connection: close", we can read from BODY. (match (assq 'connection (response-headers resp)) (('connection 'close) - (close-port p) - (connect tail result)) ;try again + (close-connection p) + (connect #f tail result)) ;try again (_ (loop tail result)))))))))) ;keep going @@ -539,40 +590,41 @@ if file doesn't exist, and the narinfo otherwise." (set! done (+ 1 done))))) (define (handle-narinfo-response request response port result) - (let ((len (response-content-length response))) + (let* ((code (response-code response)) + (len (response-content-length response)) + (cache (response-cache-control response)) + (ttl (and cache (assoc-ref cache 'max-age)))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. - (case (response-code response) - ((200) ; hit - (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! url (narinfo-path narinfo) narinfo) - (update-progress!) - (cons narinfo result))) - ((404) ; failure - (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" - (if len - (get-bytevector-n port len) - (read-to-eof port)) - (cache-narinfo! url - (find (cut string-contains <> hash-part) paths) - #f) - (update-progress!) - result)) - (else ; transient failure - (if len - (get-bytevector-n port len) - (read-to-eof port)) - result)))) - - (define (do-fetch uri) + (if (= code 200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) + (update-progress!) + (cons narinfo result)) + (let* ((path (uri-path (request-uri request))) + (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! url + (find (cut string-contains <> hash-part) paths) + #f + (if (= 404 code) + ttl + %narinfo-transient-error-ttl)) + (update-progress!) + result)))) + + (define (do-fetch uri port) (case (and=> uri uri-scheme) - ((http) + ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) - (let ((result (http-multiple-get url + (let ((result (http-multiple-get uri handle-narinfo-response '() - requests))) + requests + #:port port))) + (close-connection port) (newline (current-error-port)) result))) ((file #f) @@ -585,17 +637,17 @@ if file doesn't exist, and the narinfo otherwise." (leave (_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) - (define cache-info - (download-cache-info url)) - - (and cache-info - (if (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (do-fetch (string->uri url)) - (begin - (warning (_ "'~a' uses different store '~a'; ignoring it~%") - url (cache-info-store-directory cache-info)) - #f)))) + (let-values (((cache-info port) + (download-cache-info url))) + (and cache-info + (if (string=? (cache-info-store-directory cache-info) + (%store-prefix)) + (do-fetch (string->uri url) port) ;reuse PORT + (begin + (warning (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + (close-connection port) + #f))))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no @@ -657,12 +709,12 @@ indefinitely." (call-with-input-file file (lambda (port) (match (read port) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value #f)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl _) ('value #f)) (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value _)) - (obsolete? date now %narinfo-ttl)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl ttl) ('value _)) + (obsolete? date now ttl)) (_ #t))))) (lambda args ;; FILE may have been deleted. @@ -724,7 +776,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (make-custom-binary-input-port "progress-port-proc" read! #f #f - (cut close-port port))) + (cut close-connection port))) (define-syntax with-networking (syntax-rules () @@ -902,15 +954,9 @@ substitutes may be unavailable\n"))))) found." (assoc-ref (daemon-options) option)) -(define-syntax-rule (or* a b) - (let ((first a)) - (if (or (not first) (string-null? first)) - b - first))) - (define %cache-urls - (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client - (find-daemon-option "substitute-urls")) ;admin + (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client + (find-daemon-option "substitute-urls")) ;admin string-tokenize) ((urls ...) urls) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 401aa8b60a..8ebeb4d595 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -21,6 +21,7 @@ #:use-module (guix config) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) @@ -127,7 +128,8 @@ TARGET, and register them." (define (install-grub* grub.cfg device target) "This is a variant of 'install-grub' with error handling, lifted in %STORE-MONAD" - (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (let* ((gc-root (string-append target %gc-roots-directory + "/grub.cfg")) (temp-gc-root (string-append gc-root ".new")) (delete-file (lift1 delete-file %store-monad)) (make-symlink (lift2 switch-symlinks %store-monad)) @@ -685,6 +687,7 @@ Build the operating system declared in FILE according to ACTION.\n")) ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0) @@ -812,6 +815,7 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (process-command command args opts)))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (process-command command args opts))))) ;;; system.scm ends here diff --git a/guix/store.scm b/guix/store.scm index 8746d3c2d6..ae52628545 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -93,6 +94,7 @@ path-info-nar-size references + references/substitutes requisites referrers optimize-store @@ -502,8 +504,12 @@ encoding conversion errors." (status k)))))))) (define %default-substitute-urls - ;; Default list of substituters. - '("http://hydra.gnu.org")) + ;; Default list of substituters. This is *not* the list used by + ;; 'guix-daemon', and few clients use it ('guix build --log-file' uses it.) + (map (if (false-if-exception (resolve-interface '(gnutls))) + (cut string-append "https://" <>) + (cut string-append "http://" <>)) + '("hydra.gnu.org"))) (define* (set-build-options server #:key keep-failed? keep-going? fallback? @@ -724,6 +730,63 @@ error if there is no such root." "Return the list of references of PATH." store-path-list)) +(define %reference-cache + ;; Brute-force cache mapping store items to their list of references. + ;; Caching matters because when building a profile in the presence of + ;; grafts, we keep calling 'graft-derivation', which in turn calls + ;; 'references/substitutes' many times with the same arguments. Ideally we + ;; would use a cache associated with the daemon connection instead (XXX). + (make-hash-table 100)) + +(define (references/substitutes store items) + "Return the list of list of references of ITEMS; the result has the same +length as ITEMS. Query substitute information for any item missing from the +store at once. Raise a '&nix-protocol-error' exception if reference +information for one of ITEMS is missing." + (let* ((local-refs (map (lambda (item) + (or (hash-ref %reference-cache item) + (guard (c ((nix-protocol-error? c) #f)) + (references store item)))) + items)) + (missing (fold-right (lambda (item local-ref result) + (if local-ref + result + (cons item result))) + '() + items local-refs)) + + ;; Query all the substitutes at once to minimize the cost of + ;; launching 'guix substitute' and making HTTP requests. + (substs (substitutable-path-info store missing))) + (when (< (length substs) (length missing)) + (raise (condition (&nix-protocol-error + (message "cannot determine \ +the list of references") + (status 1))))) + + ;; Intersperse SUBSTS and LOCAL-REFS. + (let loop ((items items) + (local-refs local-refs) + (result '())) + (match items + (() + (let ((result (reverse result))) + (for-each (cut hash-set! %reference-cache <> <>) + items result) + result)) + ((item items ...) + (match local-refs + ((#f tail ...) + (loop items tail + (cons (any (lambda (subst) + (and (string=? (substitutable-path subst) item) + (substitutable-references subst))) + substs) + result))) + ((head tail ...) + (loop items tail + (cons head result))))))))) + (define* (fold-path store proc seed path #:optional (relatives (cut references store <>))) "Call PROC for each of the RELATIVES of PATH, exactly once, and return the @@ -811,7 +874,9 @@ topological order." (operation (query-substitutable-path-infos (store-path-list paths)) "Return information about the subset of PATHS that is substitutable. For each substitutable path, a `substitutable?' object is -returned." +returned; thus, the resulting list can be shorter than PATHS. Furthermore, +that there is no guarantee that the order of the resulting list matches the +order of PATHS." substitutable-path-list)) (define-operation (optimize-store) diff --git a/guix/tests.scm b/guix/tests.scm index 80c174509d..3cb4a671af 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -132,21 +132,23 @@ given by REPLACEMENT." ;;; (define* (derivation-narinfo drv #:key (nar "example.nar") - (sha256 (make-bytevector 32 0))) - "Return the contents of the narinfo corresponding to DRV; NAR should be the -file name of the archive containing the substitute for DRV, and SHA256 is the -expected hash." + (sha256 (make-bytevector 32 0)) + (references '())) + "Return the contents of the narinfo corresponding to DRV, with the specified +REFERENCES (a list of store items); NAR should be the file name of the archive +containing the substitute for DRV, and SHA256 is the expected hash." (format #f "StorePath: ~a URL: ~a Compression: none NarSize: 1234 NarHash: sha256:~a -References: +References: ~a System: ~a Deriver: ~a~%" (derivation->output-path drv) ; StorePath nar ; URL (bytevector->nix-base32-string sha256) ; NarHash + (string-join (map basename references)) ; References (derivation-system drv) ; System (basename (derivation-file-name drv)))) ; Deriver @@ -157,7 +159,9 @@ Deriver: ~a~%" (compose uri-path string->uri)))) (define* (call-with-derivation-narinfo drv thunk - #:key (sha256 (make-bytevector 32 0))) + #:key + (sha256 (make-bytevector 32 0)) + (references '())) "Call THUNK in a context where fake substituter data, as read by 'guix substitute', has been installed for DRV. SHA256 is the hash of the expected output of DRV." @@ -174,27 +178,36 @@ expected output of DRV." (%store-prefix)))) (call-with-output-file narinfo (lambda (p) - (display (derivation-narinfo drv #:sha256 sha256) p)))) + (display (derivation-narinfo drv #:sha256 sha256 + #:references references) + p)))) thunk (lambda () (delete-file narinfo) (delete-file info))))) (define-syntax with-derivation-narinfo - (syntax-rules (sha256 =>) + (syntax-rules (sha256 references =>) "Evaluate BODY in a context where DRV looks substitutable from the substituter's viewpoint." - ((_ drv (sha256 => hash) body ...) + ((_ drv (sha256 => hash) (references => refs) body ...) (call-with-derivation-narinfo drv (lambda () body ...) - #:sha256 hash)) + #:sha256 hash + #:references refs)) + ((_ drv (sha256 => hash) body ...) + (with-derivation-narinfo drv + (sha256 => hash) (references => '()) + body ...)) ((_ drv body ...) (call-with-derivation-narinfo drv (lambda () body ...))))) (define* (call-with-derivation-substitute drv contents thunk - #:key sha256) + #:key + sha256 + (references '())) "Call THUNK in a context where a substitute for DRV has been installed, using CONTENTS, a string, as its contents. If SHA256 is true, use it as the expected hash of the substitute; otherwise use the hash of the nar containing @@ -214,7 +227,8 @@ CONTENTS." ;; Create fake substituter data, to be read by 'guix substitute'. (call-with-derivation-narinfo drv thunk - #:sha256 (or sha256 hash)))) + #:sha256 (or sha256 hash) + #:references references))) (lambda () (delete-file (string-append dir "/example.out")) (delete-file (string-append dir "/example.nar"))))) @@ -231,13 +245,18 @@ all included." (> (string-length shebang) 128)) (define-syntax with-derivation-substitute - (syntax-rules (sha256 =>) + (syntax-rules (sha256 references =>) "Evaluate BODY in a context where DRV is substitutable with the given CONTENTS." - ((_ drv contents (sha256 => hash) body ...) + ((_ drv contents (sha256 => hash) (references => refs) body ...) (call-with-derivation-substitute drv contents (lambda () body ...) - #:sha256 hash)) + #:sha256 hash + #:references refs)) + ((_ drv contents (sha256 => hash) body ...) + (with-derivation-substitute drv contents + (sha256 => hash) (references => '()) + body ...)) ((_ drv contents body ...) (call-with-derivation-substitute drv contents (lambda () diff --git a/guix/ui.scm b/guix/ui.scm index 7310773310..7b7bee0ac8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -410,6 +410,12 @@ interpreted." (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." + (define (port-filename* port) + ;; 'port-filename' returns #f for non-file ports, but it raises an + ;; exception for file ports that are closed. Work around that. + (and (not (port-closed? port)) + (port-filename port))) + (guard (c ((package-input-error? c) (let* ((package (package-error-package c)) (input (package-error-invalid-input c)) @@ -440,9 +446,9 @@ interpreted." (port (nar-error-port c))) (if file (leave (_ "corrupt input while restoring '~a' from ~s~%") - file (or (port-filename port) port)) + file (or (port-filename* port) port)) (leave (_ "corrupt input while restoring archive from ~s~%") - (or (port-filename port) port))))) + (or (port-filename* port) port))))) ((nix-connection-error? c) (leave (_ "failed to connect to `~a': ~a~%") (nix-connection-error-file c) @@ -1081,9 +1087,9 @@ package name, version number (or #f), and output name (or OUTPUT). SPEC may optionally contain a version number and an output name, as in these examples: guile - guile-2.0.9 + guile@2.0.9 guile:debug - guile-2.0.9:debug + guile@2.0.9:debug " (let*-values (((name sub-drv) (match (string-rindex spec #\:) diff --git a/guix/upstream.scm b/guix/upstream.scm index c62667dd01..cea23feb82 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -99,7 +99,7 @@ correspond to the same version." (upstream-source-urls head))) (signature-urls (let ((one (upstream-source-signature-urls release)) - (two (upstream-source-signature-urls release))) + (two (upstream-source-signature-urls head))) (and one two (append one two))))) tail) (cons release result))) diff --git a/guix/utils.scm b/guix/utils.scm index c61f105513..de541799fa 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -3,6 +3,7 @@ ;;; 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> +;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -31,8 +32,7 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) - #:use-module ((guix build utils) - #:select (dump-port package-name->name+version)) + #:use-module ((guix build utils) #:select (dump-port)) #:use-module ((guix build syscalls) #:select (errno mkdtemp!)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -42,7 +42,6 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (system foreign) - #:re-export (package-name->name+version) #:export (bytevector->base16-string base16-string->bytevector @@ -66,6 +65,7 @@ gnu-triplet->nix-system %current-system %current-target-system + package-name->name+version version-compare version>? version>=? @@ -544,6 +544,15 @@ returned by `config.guess'." ;; cross-building to. (make-parameter #f)) +(define (package-name->name+version spec) + "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 #\@) + (#f (values spec #f)) + (idx (values (substring spec 0 idx) + (substring spec (1+ idx)))))) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) |