From mboxrd@z Thu Jan 1 00:00:00 1970 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Subject: bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails. Date: Tue, 17 Oct 2017 10:48:07 +0200 Message-ID: <20171017084807.15901-5-ludo@gnu.org> References: <20171017084807.15901-1-ludo@gnu.org> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:35930) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e4NYf-0001gY-OU for bug-guix@gnu.org; Tue, 17 Oct 2017 04:49:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e4NYc-0003Mb-0r for bug-guix@gnu.org; Tue, 17 Oct 2017 04:49:05 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:36149) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1e4NYb-0003MF-T7 for bug-guix@gnu.org; Tue, 17 Oct 2017 04:49:01 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1e4NYb-0001L0-KH for bug-guix@gnu.org; Tue, 17 Oct 2017 04:49:01 -0400 Sender: "Debbugs-submit" Resent-Message-ID: In-Reply-To: <20171017084807.15901-1-ludo@gnu.org> List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org Sender: "bug-Guix" To: 28709@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= From: Ludovic Courtès Fixes . * 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. --- Makefile.am | 1 + guix/build/download-nar.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++ guix/cvs-download.scm | 38 ++++++++++---- guix/git-download.scm | 37 ++++++++++--- guix/hg-download.scm | 36 +++++++++---- 5 files changed, 211 insertions(+), 26 deletions(-) create mode 100644 guix/build/download-nar.scm diff --git a/Makefile.am b/Makefile.am index 071553b99..2855b4efd 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 000000000..13f01fb1e --- /dev/null +++ b/guix/build/download-nar.scm @@ -0,0 +1,125 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 . + +(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 85744c5b5..8b46f8ef8 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 +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2014 Sree Harsha Totakura ;;; Copyright © 2015 Mark H Weaver ;;; @@ -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 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 7397cbe7f..731e549b3 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 842098090..6b25b87b6 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 +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; 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 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 -- 2.14.2