diff options
author | Ludovic Courtès <ludovic.courtes@inria.fr> | 2017-10-17 10:34:03 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2017-10-19 23:21:49 +0200 |
commit | 37ce440dcffa9ff4f5401bacbc9619bd8ea561c1 (patch) | |
tree | 43abe15321bd541a27d04b4b1faf556cf3e5acb0 | |
parent | 8c3488259ea9e8d18a2c5b947cf9a137a12546a6 (diff) | |
download | guix-37ce440dcffa9ff4f5401bacbc9619bd8ea561c1.tar guix-37ce440dcffa9ff4f5401bacbc9619bd8ea561c1.tar.gz |
download: Download a nar when a VCS checkout fails.
Fixes <https://bugs.gnu.org/28709>.
* guix/build/download-nar.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/cvs-download.scm (cvs-fetch)[zlib, config.scm, modules]: New
variables.
[build]: Use MODULES. Add call to 'download-nar'.
* guix/git-download.scm (git-fetch): Likewise.
* guix/hg-download.scm (hg-fetch): Likewise.
-rw-r--r-- | Makefile.am | 1 | ||||
-rw-r--r-- | guix/build/download-nar.scm | 125 | ||||
-rw-r--r-- | guix/cvs-download.scm | 38 | ||||
-rw-r--r-- | guix/git-download.scm | 37 | ||||
-rw-r--r-- | guix/hg-download.scm | 36 |
5 files changed, 211 insertions, 26 deletions
diff --git a/Makefile.am b/Makefile.am index 071553b997..2855b4efdd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -106,6 +106,7 @@ MODULES = \ guix/ui.scm \ guix/build/ant-build-system.scm \ guix/build/download.scm \ + guix/build/download-nar.scm \ guix/build/cargo-build-system.scm \ guix/build/cmake-build-system.scm \ guix/build/dub-build-system.scm \ diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm new file mode 100644 index 0000000000..13f01fb1e8 --- /dev/null +++ b/guix/build/download-nar.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build download-nar) + #:use-module (guix build download) + #:use-module (guix build utils) + #:use-module (guix serialization) + #:use-module (guix zlib) + #:use-module (guix progress) + #:use-module (web uri) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export (download-nar)) + +;;; Commentary: +;;; +;;; Download a normalized archive or "nar", similar to what 'guix substitute' +;;; does. The intent here is to use substitute servers as content-addressed +;;; mirrors of VCS checkouts. This is mostly useful for users who have +;;; disabled substitutes. +;;; +;;; Code: + +(define (urls-for-item item) + "Return the fallback nar URL for ITEM--e.g., +\"/gnu/store/cabbag3…-foo-1.2-checkout\"." + ;; Here we hard-code nar URLs without checking narinfos. That's probably OK + ;; though. + ;; TODO: Use HTTPS? The downside is the extra dependency. + (let ((bases '("http://mirror.hydra.gnu.org/guix" + "http://berlin.guixsd.org")) + (item (basename item))) + (append (map (cut string-append <> "/nar/gzip/" item) bases) + (map (cut string-append <> "/nar/" item) bases)))) + +(define (restore-gzipped-nar port item size) + "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to +ITEM." + ;; Since PORT is typically a non-file port (for instance because 'http-get' + ;; returns a delimited port), create a child process so we're back to a file + ;; port that can be passed to 'call-with-gzip-input-port'. + (match (pipe) + ((input . output) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port output) + (close-port port) + (catch #t + (lambda () + (call-with-gzip-input-port input + (cut restore-file <> item))) + (lambda (key . args) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 1) + key args) + (primitive-exit 1)))) + (lambda () + (primitive-exit 0)))) + (child + (close-port input) + (dump-port* port output + #:reporter (progress-reporter/file item size + #:abbreviation + store-path-abbreviation)) + (close-port output) + (newline) + (match (waitpid child) + ((_ . status) + (unless (zero? status) + (error "nar decompression failed" status))))))))) + +(define (download-nar item) + "Download and extract the normalized archive for ITEM. Return #t on +success, #f otherwise." + ;; Let progress reports go through. + (setvbuf (current-error-port) _IONBF) + (setvbuf (current-output-port) _IONBF) + + (let loop ((urls (urls-for-item item))) + (match urls + ((url rest ...) + (format #t "Trying content-addressed mirror at ~a...~%" + (uri-host (string->uri url))) + (let-values (((port size) + (catch #t + (lambda () + (http-fetch (string->uri url))) + (lambda args + (values #f #f))))) + (if (not port) + (loop rest) + (begin + (if size + (format #t "Downloading from ~a (~,2h MiB)...~%" url + (/ size (expt 2 20.))) + (format #t "Downloading from ~a...~%" url)) + (if (string-contains url "/gzip") + (restore-gzipped-nar port item size) + (begin + ;; FIXME: Add progress report. + (restore-file port item) + (close-port port))) + #t)))) + (() + #f)))) diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index 85744c5b55..8b46f8ef8c 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.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 © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; @@ -23,6 +23,7 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix modules) #:use-module (guix packages) #:use-module (ice-9 match) #:export (cvs-reference @@ -59,16 +60,35 @@ "Return a fixed-output derivation that fetches REF, a <cvs-reference> object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build cvs) + (guix build download-nar)))))) (define build - (with-imported-modules '((guix build cvs) - (guix build utils)) + (with-imported-modules modules #~(begin - (use-modules (guix build cvs)) - (cvs-fetch '#$(cvs-reference-root-directory ref) - '#$(cvs-reference-module ref) - '#$(cvs-reference-revision ref) - #$output - #:cvs-command (string-append #+cvs "/bin/cvs"))))) + (use-modules (guix build cvs) + (guix build download-nar)) + + (or (cvs-fetch '#$(cvs-reference-root-directory ref) + '#$(cvs-reference-module ref) + '#$(cvs-reference-revision ref) + #$output + #:cvs-command (string-append #+cvs "/bin/cvs")) + (download-nar #$output))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "cvs-checkout") build diff --git a/guix/git-download.scm b/guix/git-download.scm index 7397cbe7f5..731e549b38 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -25,6 +25,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) #:use-module (ice-9 popen) @@ -77,12 +78,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (standard-packages) '())) + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build git) + (guix build utils) + (guix build download-nar)))))) + (define build - (with-imported-modules '((guix build git) - (guix build utils)) + (with-imported-modules modules #~(begin (use-modules (guix build git) (guix build utils) + (guix build download-nar) (ice-9 match)) ;; The 'git submodule' commands expects Coreutils, sed, @@ -92,12 +112,13 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (((names dirs) ...) dirs))) - (git-fetch (getenv "git url") (getenv "git commit") - #$output - #:recursive? (call-with-input-string - (getenv "git recursive?") - read) - #:git-command (string-append #+git "/bin/git"))))) + (or (git-fetch (getenv "git url") (getenv "git commit") + #$output + #:recursive? (call-with-input-string + (getenv "git recursive?") + read) + #:git-command (string-append #+git "/bin/git")) + (download-nar #$output))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 8420980905..6b25b87b6b 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.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 © 2016 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix records) + #:use-module (guix modules) #:use-module (guix packages) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) @@ -59,18 +60,35 @@ "Return a fixed-output derivation that fetches REF, a <hg-reference> object. The output is expected to have recursive hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build hg) + (guix build download-nar)))))) + (define build - (with-imported-modules '((guix build hg) - (guix build utils)) + (with-imported-modules modules #~(begin (use-modules (guix build hg) - (guix build utils) - (ice-9 match)) + (guix build download-nar)) - (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg"))))) + (or (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg")) + (download-nar #$output))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "hg-checkout") build |