From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: Content-addressed mirrors for Git checkouts Resent-From: ludo@gnu.org (Ludovic =?UTF-8?Q?Court=C3=A8s?=) Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Wed, 04 Oct 2017 21:50:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 28709@debbugs.gnu.org Cc: Leo Famulari X-Debbugs-Original-To: bug-guix@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.150715379430452 (code B ref -1); Wed, 04 Oct 2017 21:50:01 +0000 Received: (at submit) by debbugs.gnu.org; 4 Oct 2017 21:49:54 +0000 Received: from localhost ([127.0.0.1]:49429 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dzrYA-0007v3-5N for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:54 -0400 Received: from eggs.gnu.org ([208.118.235.92]:42698) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dzrY8-0007ur-Dg for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:52 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dzrY1-0002XE-Ma for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:47 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-0.0 required=5.0 tests=BAYES_20,RP_MATCHES_RCVD, URIBL_BLOCKED autolearn=disabled version=3.3.2 Received: from lists.gnu.org ([2001:4830:134:3::11]:41576) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1dzrY1-0002XA-Io for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:45 -0400 Received: from eggs.gnu.org ([2001:4830:134:3::10]:33657) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dzrXz-0006Db-Oi for bug-guix@gnu.org; Wed, 04 Oct 2017 17:49:45 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dzrXy-0002V0-Ag for bug-guix@gnu.org; Wed, 04 Oct 2017 17:49:43 -0400 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:38293) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dzrXu-0002SF-Rl; Wed, 04 Oct 2017 17:49:38 -0400 Received: from [2a01:e0a:1d:7270:6a6c:dc17:fc02:cfda] (port=47948 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1dzrXu-0007sS-Dg; Wed, 04 Oct 2017 17:49:38 -0400 From: ludo@gnu.org (Ludovic =?UTF-8?Q?Court=C3=A8s?=) X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 13 =?UTF-8?Q?Vend=C3=A9miaire?= an 226 de la =?UTF-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Wed, 04 Oct 2017 23:49:36 +0200 Message-ID: <8760bu60sv.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.3 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 2001:4830:134:3::11 X-Spam-Score: -5.0 (-----) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -5.0 (-----) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello! Someone on #guix reported a failure to build Guile-Git from Guix 0.13.0 because the old repo at gitlab.com has disappeared. For tarballs, we have content addressed mirrors, in particular the /file URL of =E2=80=98guix publish=E2=80=99. However, that=E2=80=99s only for re= gular files, not for directories like Git checkouts. For directories (and store items in general), we have the /nar URLs though (normally used for substitutes). This patch uses /nar URLs as a fallback mirror (it=E2=80=99s content-addressed, even though the hash in th= e URL is not directly the content hash) for Git clones that fail. It=E2=80=99s rough on the edges (no TLS, no compression), but it shows that= it=E2=80=99s a viable solution. It would take some thought to avoid duplicating it between git, hg, etc. Thoughts? Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable diff --git a/guix/build/git.scm b/guix/build/git.scm index c1af545a7..223e79227 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright =C2=A9 2014, 2016 Ludovic Court=C3=A8s +;;; Copyright =C2=A9 2014, 2016, 2017 Ludovic Court=C3=A8s ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,14 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (guix build git) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (guix serialization) #:use-module (guix build utils) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:use-module (ice-9 match) #:export (git-fetch)) =20 ;;; Commentary: @@ -27,6 +34,37 @@ ;;; ;;; Code: =20 +(define (urls-for-item item) + "Return the fallback nar URL for ITEM--e.g., \"cabbag3=E2=80=A6-foo-1.2-= checkout\"." + ;; TODO: Use the /gzip URLs, make it configurable, and use TLS. + (list (string-append "http://mirror.hydra.gnu.org/guix/nar/" item) + (string-append "http://berlin.guixsd.org/nar/" item))) + +(define (download-nar item directory) + "Download Git checkout ITEM to DIRECTORY as a nar." + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-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 (((response port) + (http-get url #:streaming? #t))) + (if (=3D 200 (response-code response)) + (let ((size (response-content-length response))) + (if size + (format #t "Downloading from ~a (~,2h MiB)...~%" + url (/ size (expt 2 20.))) + (format #t "Downloading from ~a...~%" url)) + (restore-file port directory) + (close-port port) + #t) + (loop rest)))) + (() + #f)))) + (define* (git-fetch url commit directory #:key (git-command "git") recursive?) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit @@ -39,26 +77,27 @@ recursively. Return #t on success, #f otherwise." =20 ;; We cannot use "git clone --recursive" since the following "git checko= ut" ;; effectively removes sub-module checkouts as of Git 2.6.3. - (and (zero? (system* git-command "clone" url directory)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - (when recursive? - ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" - "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (if (zero? (system* git-command "clone" url directory)) + (with-directory-excursion directory + (system* git-command "tag" "-l") + (and (zero? (system* git-command "checkout" commit)) + (begin + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" + "--init" "--recursive")) + (error "failed to fetch sub-modules" url)) =20 - ;; In sub-modules, '.git' is a flat file, not a director= y, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) =20 - ;; The contents of '.git' vary as a function of the current - ;; status of the Git repo. Since we want a fixed output, = this - ;; directory needs to be taken out. - (delete-file-recursively ".git") - #t))))) + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, t= his + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t))) + (download-nar (basename directory) directory))) =20 ;;; git.scm ends here diff --git a/guix/git-download.scm b/guix/git-download.scm index 7397cbe7f..ffae8fcc3 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) @@ -78,8 +79,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a ge= neric name if #f." '())) =20 (define build - (with-imported-modules '((guix build git) - (guix build utils)) + (with-imported-modules (source-module-closure + '((guix build git))) #~(begin (use-modules (guix build git) (guix build utils) --=-=-=-- From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Tue, 17 Oct 2017 08:49:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 28709@debbugs.gnu.org Cc: iyzsong@member.fsf.org, Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 28709-submit@debbugs.gnu.org id=B28709.15082301125076 (code B ref 28709); Tue, 17 Oct 2017 08:49:01 +0000 Received: (at 28709) by debbugs.gnu.org; 17 Oct 2017 08:48:32 +0000 Received: from localhost ([127.0.0.1]:44817 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY2-0001JN-DL for submit@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:32 -0400 Received: from eggs.gnu.org ([208.118.235.92]:44668) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY1-0001J7-Gh for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:26 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e4NXu-000303-Bq for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:20 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:43185) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e4NXu-0002zy-7S; Tue, 17 Oct 2017 04:48:18 -0400 Received: from [193.50.110.215] (port=59998 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1e4NXt-0007UM-No; Tue, 17 Oct 2017 04:48:18 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 17 Oct 2017 10:48:07 +0200 Message-Id: <20171017084807.15901-5-ludo@gnu.org> X-Mailer: git-send-email 2.14.2 In-Reply-To: <20171017084807.15901-1-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 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:4830:134:3::e X-Spam-Score: -5.0 (-----) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -0.0 (/) 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 From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Tue, 17 Oct 2017 08:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 28709@debbugs.gnu.org Cc: iyzsong@member.fsf.org, Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 28709-submit@debbugs.gnu.org id=B28709.15082301135085 (code B ref 28709); Tue, 17 Oct 2017 08:49:02 +0000 Received: (at 28709) by debbugs.gnu.org; 17 Oct 2017 08:48:33 +0000 Received: from localhost ([127.0.0.1]:44824 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY8-0001Ju-RV for submit@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:33 -0400 Received: from eggs.gnu.org ([208.118.235.92]:44702) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY4-0001JC-DO for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:28 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e4NXy-00032D-Ix for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:23 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-0.5 required=5.0 tests=BAYES_05,RP_MATCHES_RCVD autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:43181) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e4NXq-0002xB-Uz; Tue, 17 Oct 2017 04:48:14 -0400 Received: from [193.50.110.215] (port=59998 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1e4NXq-0007UM-H3; Tue, 17 Oct 2017 04:48:14 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 17 Oct 2017 10:48:04 +0200 Message-Id: <20171017084807.15901-2-ludo@gnu.org> X-Mailer: git-send-email 2.14.2 In-Reply-To: <20171017084807.15901-1-ludo@gnu.org> References: <20171017084807.15901-1-ludo@gnu.org> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:4830:134:3::e X-Spam-Score: -5.0 (-----) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -5.0 (-----) This is a followup to 36626c556ed75219bce196ac93d148f6b9af984c. * guix/build/download.scm (http-fetch): Rename 'port-or-bv' to 'port'. Assume (port? port) is always true, and remove other branch. --- guix/build/download.scm | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/guix/build/download.scm b/guix/build/download.scm index 9490f4805..e227ae598 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -774,7 +774,7 @@ certificates; otherwise simply ignore them." #:timeout timeout #:verify-certificate? verify-certificate?)) - ((resp bv-or-port) + ((resp port) (http-get uri #:port connection #:decode-body? #f #:streaming? #t #:headers headers)) @@ -787,14 +787,11 @@ certificates; otherwise simply ignore them." (begin (call-with-output-file file (lambda (p) - (if (port? bv-or-port) - (begin - (dump-port* bv-or-port p - #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)) - (newline)) - (put-bytevector p bv-or-port)))) + (dump-port* port p + #:buffer-size %http-receive-buffer-size + #:reporter (progress-reporter/file + (uri-abbreviation uri) size)) + (newline))) file)) ((301 ; moved permanently 302 ; found (redirection) -- 2.14.2 From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts References: <8760bu60sv.fsf@gnu.org> In-Reply-To: <8760bu60sv.fsf@gnu.org> Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Tue, 17 Oct 2017 08:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 28709@debbugs.gnu.org Cc: iyzsong@member.fsf.org, Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 28709-submit@debbugs.gnu.org id=B28709.15082301135091 (code B ref 28709); Tue, 17 Oct 2017 08:49:02 +0000 Received: (at 28709) by debbugs.gnu.org; 17 Oct 2017 08:48:33 +0000 Received: from localhost ([127.0.0.1]:44826 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY9-0001Jz-4Q for submit@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:33 -0400 Received: from eggs.gnu.org ([208.118.235.92]:44701) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY4-0001JB-DN for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:28 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e4NXy-000323-IC for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:23 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-0.0 required=5.0 tests=BAYES_20,RP_MATCHES_RCVD autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:43180) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e4NXq-0002wb-2a; Tue, 17 Oct 2017 04:48:14 -0400 Received: from [193.50.110.215] (port=59998 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1e4NXp-0007UM-IJ; Tue, 17 Oct 2017 04:48:13 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 17 Oct 2017 10:48:03 +0200 Message-Id: <20171017084807.15901-1-ludo@gnu.org> X-Mailer: git-send-email 2.14.2 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:4830:134:3::e X-Spam-Score: -5.0 (-----) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -5.0 (-----) Hello, Here’s a ready-to-merge patch series. Once applied, nars (aka. “substitutes”) are downloaded and extracted when a VCS checkout fails. This will address cases such as the recent Guile-Git repository renaming for people who have disabled substitutes. I’m Cc’ing 宋文武 because this also moves the progress-report code to a new (guix progress) module. Feedback welcome! Ludo’. Ludovic Courtès (4): download: Remove old-Guile leftovers. download: Make 'http-fetch' public. Add (guix progress). download: Download a nar when a VCS checkout fails. Makefile.am | 2 + guix/build/download-nar.scm | 125 ++++++++++++++++++++++++ guix/build/download.scm | 216 +++++------------------------------------ guix/cvs-download.scm | 38 ++++++-- guix/git-download.scm | 37 +++++-- guix/hg-download.scm | 36 +++++-- guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/download.scm | 4 +- guix/scripts/substitute.scm | 5 +- guix/utils.scm | 28 +----- 10 files changed, 470 insertions(+), 249 deletions(-) create mode 100644 guix/build/download-nar.scm create mode 100644 guix/progress.scm -- 2.14.2 From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: [PATCH 2/4] download: Make 'http-fetch' public. Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Tue, 17 Oct 2017 08:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 28709@debbugs.gnu.org Cc: iyzsong@member.fsf.org, Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 28709-submit@debbugs.gnu.org id=B28709.15082301145100 (code B ref 28709); Tue, 17 Oct 2017 08:49:02 +0000 Received: (at 28709) by debbugs.gnu.org; 17 Oct 2017 08:48:34 +0000 Received: from localhost ([127.0.0.1]:44828 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NYA-0001KB-DQ for submit@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:34 -0400 Received: from eggs.gnu.org ([208.118.235.92]:44710) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY5-0001JE-Kp for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:29 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e4NXz-00032l-E1 for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:24 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-0.0 required=5.0 tests=BAYES_40,RP_MATCHES_RCVD autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:43182) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e4NXs-0002yg-2q; Tue, 17 Oct 2017 04:48:16 -0400 Received: from [193.50.110.215] (port=59998 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1e4NXr-0007UM-E6; Tue, 17 Oct 2017 04:48:15 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 17 Oct 2017 10:48:05 +0200 Message-Id: <20171017084807.15901-3-ludo@gnu.org> X-Mailer: git-send-email 2.14.2 In-Reply-To: <20171017084807.15901-1-ludo@gnu.org> References: <20171017084807.15901-1-ludo@gnu.org> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:4830:134:3::e X-Spam-Score: -5.0 (-----) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -5.0 (-----) * guix/build/download.scm (http-fetch): Remove 'file' parameter. Change to return an input port and the content-length. Make public. (url-fetch): Adjust accordingly. --- guix/build/download.scm | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/guix/build/download.scm b/guix/build/download.scm index e227ae598..3b89f9412 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -39,6 +39,7 @@ #:use-module (ice-9 format) #:export (open-socket-for-uri open-connection-for-uri + http-fetch %x509-certificate-directory close-connection resolve-uri-reference @@ -745,11 +746,11 @@ Return the resulting target URI." #:query (uri-query ref) #:fragment (uri-fragment ref))))) -(define* (http-fetch uri file #:key timeout (verify-certificate? #t)) - "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if -the connection could not be established in less than TIMEOUT seconds. Return -FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS -certificates; otherwise simply ignore them." +(define* (http-fetch uri #:key timeout (verify-certificate? #t)) + "Return an input port containing the data at URI, and the expected number of +bytes available or #f. When TIMEOUT is true, bail out if the connection could +not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is +true, verify HTTPS certificates; otherwise simply ignore them." (define headers `(;; Some web sites, such as http://dist.schmorp.de, would block you if @@ -779,20 +780,10 @@ certificates; otherwise simply ignore them." #:streaming? #t #:headers headers)) ((code) - (response-code resp)) - ((size) - (response-content-length resp))) + (response-code resp))) (case code ((200) ; OK - (begin - (call-with-output-file file - (lambda (p) - (dump-port* port p - #:buffer-size %http-receive-buffer-size - #:reporter (progress-reporter/file - (uri-abbreviation uri) size)) - (newline))) - file)) + (values port (response-content-length resp))) ((301 ; moved permanently 302 ; found (redirection) 303 ; see other @@ -802,7 +793,7 @@ certificates; otherwise simply ignore them." (format #t "following redirection to `~a'...~%" (uri->string uri)) (close connection) - (http-fetch uri file + (http-fetch uri #:timeout timeout #:verify-certificate? verify-certificate?))) (else @@ -873,10 +864,19 @@ otherwise simply ignore them." file (uri->string uri)) (case (uri-scheme uri) ((http https) - (false-if-exception* (http-fetch uri file - #:verify-certificate? - verify-certificate? - #:timeout timeout))) + (false-if-exception* + (let-values (((port size) + (http-fetch uri + #:verify-certificate? verify-certificate? + #:timeout timeout))) + (call-with-output-file file + (lambda (output) + (dump-port* port output + #:buffer-size %http-receive-buffer-size + #:reporter (progress-reporter/file + (uri-abbreviation uri) size)) + (newline))) + #t))) ((ftp) (false-if-exception* (ftp-fetch uri file #:timeout timeout))) -- 2.14.2 From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: [PATCH 3/4] Add (guix progress). Resent-From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Tue, 17 Oct 2017 08:49:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: 28709@debbugs.gnu.org Cc: iyzsong@member.fsf.org, Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 28709-submit@debbugs.gnu.org id=B28709.15082301185110 (code B ref 28709); Tue, 17 Oct 2017 08:49:03 +0000 Received: (at 28709) by debbugs.gnu.org; 17 Oct 2017 08:48:38 +0000 Received: from localhost ([127.0.0.1]:44830 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NYA-0001KD-MZ for submit@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:38 -0400 Received: from eggs.gnu.org ([208.118.235.92]:44715) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4NY6-0001JG-S9 for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:32 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1e4NXy-00032O-Q1 for 28709@debbugs.gnu.org; Tue, 17 Oct 2017 04:48:25 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,RP_MATCHES_RCVD autolearn=disabled version=3.3.2 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:43184) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1e4NXt-0002zU-93; Tue, 17 Oct 2017 04:48:17 -0400 Received: from [193.50.110.215] (port=59998 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1e4NXs-0007UM-Hc; Tue, 17 Oct 2017 04:48:17 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 17 Oct 2017 10:48:06 +0200 Message-Id: <20171017084807.15901-4-ludo@gnu.org> X-Mailer: git-send-email 2.14.2 In-Reply-To: <20171017084807.15901-1-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 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2001:4830:134:3::e X-Spam-Score: -5.0 (-----) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -0.0 (/) Among other things, this removes (guix utils), (guix ui), (guix config), etc. from the closure of (guix build download), as was the case since 798648515b77507c242752457b4dc17c155bad6e. * guix/utils.scm (, call-with-progress-reporter): Move to... * guix/progress.scm: ... here. New file. * Makefile.am (MODULES): Add it. * guix/build/download.scm (current-terminal-columns) (nearest-exact-integer, duration->seconds, seconds->string) (byte-count->string, progress-bar, string-pad-middle) (rate-limited, progress-reporter/file, dump-port*) (time-monotonic): Move to progress.scm. * guix/scripts/download.scm: Adjust accordingly. * guix/scripts/substitute.scm: Likewise. --- Makefile.am | 1 + guix/build/download.scm | 167 +------------------------------- guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/download.scm | 4 +- guix/scripts/substitute.scm | 5 +- guix/utils.scm | 28 +----- 6 files changed, 236 insertions(+), 197 deletions(-) create mode 100644 guix/progress.scm diff --git a/Makefile.am b/Makefile.am index efbd07a35..071553b99 100644 --- a/Makefile.am +++ b/Makefile.am @@ -47,6 +47,7 @@ MODULES = \ guix/hash.scm \ guix/pk-crypto.scm \ guix/pki.scm \ + guix/progress.scm \ guix/combinators.scm \ guix/memoization.scm \ guix/utils.scm \ diff --git a/guix/build/download.scm b/guix/build/download.scm index 3b89f9412..61c9c6d3f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,7 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver -;;; Copyright © 2015 Steve Sprang ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. @@ -27,7 +26,7 @@ #:use-module (guix base64) #:use-module (guix ftp-client) #:use-module (guix build utils) - #:use-module (guix utils) + #:use-module (guix progress) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -46,8 +45,6 @@ maybe-expand-mirrors url-fetch byte-count->string - current-terminal-columns - progress-reporter/file uri-abbreviation nar-uri-abbreviation store-path-abbreviation)) @@ -62,69 +59,6 @@ ;; Size of the HTTP receive buffer. 65536) -(define current-terminal-columns - ;; Number of columns of the terminal. - (make-parameter 80)) - -(define (nearest-exact-integer x) - "Given a real number X, return the nearest exact integer, with ties going to -the nearest exact even integer." - (inexact->exact (round x))) - -(define (duration->seconds duration) - "Return the number of seconds represented by DURATION, a 'time-duration' -object, as an inexact number." - (+ (time-second duration) - (/ (time-nanosecond duration) 1e9))) - -(define (seconds->string duration) - "Given DURATION in seconds, return a string representing it in 'mm:ss' or -'hh:mm:ss' format, as needed." - (if (not (number? duration)) - "00:00" - (let* ((total-seconds (nearest-exact-integer duration)) - (extra-seconds (modulo total-seconds 3600)) - (num-hours (quotient total-seconds 3600)) - (hours (and (positive? num-hours) num-hours)) - (mins (quotient extra-seconds 60)) - (secs (modulo extra-seconds 60))) - (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) - -(define (byte-count->string size) - "Given SIZE in bytes, return a string representing it in a human-readable -way." - (let ((KiB 1024.) - (MiB (expt 1024. 2)) - (GiB (expt 1024. 3)) - (TiB (expt 1024. 4))) - (cond - ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) - ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) - ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) - ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) - (else (format #f "~,3fTiB" (/ size TiB)))))) - -(define* (progress-bar % #:optional (bar-width 20)) - "Return % as a string representing an ASCII-art progress bar. The total -width of the bar is BAR-WIDTH." - (let* ((fraction (/ % 100)) - (filled (inexact->exact (floor (* fraction bar-width)))) - (empty (- bar-width filled))) - (format #f "[~a~a]" - (make-string filled #\#) - (make-string empty #\space)))) - -(define (string-pad-middle left right len) - "Combine LEFT and RIGHT with enough padding in the middle so that the -resulting string has length at least LEN (it may overflow). If the string -does not overflow, the last char in RIGHT will be flush with the LEN -column." - (let* ((total-used (+ (string-length left) - (string-length right))) - (num-spaces (max 1 (- len total-used))) - (padding (make-string num-spaces #\space))) - (string-append left padding right))) - (define* (ellipsis #:optional (port (current-output-port))) "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written in PORT's encoding, and return either that or ASCII dots." @@ -143,105 +77,6 @@ Otherwise return STORE-PATH." (string-drop base 32))) store-path)) -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - - -;; TODO: replace '(@ (guix build utils) dump-port))'. -(define* (dump-port* in out - #:key (buffer-size 16384) - (reporter (make-progress-reporter noop noop noop))) - "Read as much data as possible from IN and write it to OUT, using chunks of -BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or -less, report the total number of bytes transferred to the REPORTER, which -should be a object." - (define buffer - (make-bytevector buffer-size)) - - (call-with-progress-reporter reporter - (lambda (report) - (let loop ((total 0) - (bytes (get-bytevector-n! in buffer 0 buffer-size))) - (or (eof-object? bytes) - (let ((total (+ total bytes))) - (put-bytevector out buffer 0 bytes) - (report total) - (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) - -(define (rate-limited proc interval) - "Return a procedure that will forward the invocation to PROC when the time -elapsed since the previous forwarded invocation is greater or equal to -INTERVAL (a time-duration object), otherwise does nothing and returns #f." - (let ((previous-at #f)) - (lambda args - (let* ((now (current-time time-monotonic)) - (forward-invocation (lambda () - (set! previous-at now) - (apply proc args)))) - (if previous-at - (let ((elapsed (time-difference now previous-at))) - (if (time>=? elapsed interval) - (forward-invocation) - #f)) - (forward-invocation)))))) - -(define* (progress-reporter/file file size - #:optional (log-port (current-output-port)) - #:key (abbreviation basename)) - "Return a object to show the progress of FILE's download, -which is SIZE bytes long. The progress report is written to LOG-PORT, with -ABBREVIATION used to shorten FILE for display." - (let ((start-time (current-time time-monotonic)) - (transferred 0)) - (define (render) - "Write the progress report to LOG-PORT." - (define elapsed - (duration->seconds - (time-difference (current-time time-monotonic) start-time))) - (if (number? size) - (let* ((% (* 100.0 (/ transferred size))) - (throughput (/ transferred elapsed)) - (left (format #f " ~a ~a" - (abbreviation file) - (byte-count->string size))) - (right (format #f "~a/s ~a ~a~6,1f%" - (byte-count->string throughput) - (seconds->string elapsed) - (progress-bar %) %))) - (display "\r\x1b[K" log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (flush-output-port log-port)) - (let* ((throughput (/ transferred elapsed)) - (left (format #f " ~a" - (abbreviation file))) - (right (format #f "~a/s ~a | ~a transferred" - (byte-count->string throughput) - (seconds->string elapsed) - (byte-count->string transferred)))) - (display "\r\x1b[K" log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (flush-output-port log-port)))) - - (progress-reporter - (start render) - ;; Report the progress every 300ms or longer. - (report - (let ((rate-limited-render - (rate-limited render (make-time time-monotonic 300000000 0)))) - (lambda (value) - (set! transferred value) - (rate-limited-render)))) - ;; Don't miss the last report. - (stop render)))) - (define* (uri-abbreviation uri #:optional (max-length 42)) "If URI's string representation is larger than MAX-LENGTH, return an abbreviation of URI showing the scheme, host, and basename of the file." diff --git a/guix/progress.scm b/guix/progress.scm new file mode 100644 index 000000000..beca2c22a --- /dev/null +++ b/guix/progress.scm @@ -0,0 +1,228 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Sou Bunnbu +;;; Copyright © 2015 Steve Sprang +;;; +;;; 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 progress) + #:use-module (guix records) + #:use-module (srfi srfi-19) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:export ( + progress-reporter + make-progress-reporter + progress-reporter? + call-with-progress-reporter + + progress-reporter/silent + progress-reporter/file + + byte-count->string + current-terminal-columns + + dump-port*)) + +;;; Commentary: +;;; +;;; Helper to write progress report code for downloads, etc. +;;; +;;; Code: + +(define-record-type* + progress-reporter make-progress-reporter progress-reporter? + (start progress-reporter-start) ; thunk + (report progress-reporter-report) ; procedure + (stop progress-reporter-stop)) ; thunk + +(define (call-with-progress-reporter reporter proc) + "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} +with the resulting report procedure. When @var{proc} returns, the REPORTER is +stopped." + (match reporter + (($ start report stop) + (dynamic-wind start (lambda () (proc report)) stop)))) + +(define progress-reporter/silent + (make-progress-reporter noop noop noop)) + + +;;; +;;; File download progress report. +;;; + +(cond-expand + (guile-2.2 + ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and + ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. + (define time-monotonic time-tai)) + (else #t)) + +(define (nearest-exact-integer x) + "Given a real number X, return the nearest exact integer, with ties going to +the nearest exact even integer." + (inexact->exact (round x))) + +(define (duration->seconds duration) + "Return the number of seconds represented by DURATION, a 'time-duration' +object, as an inexact number." + (+ (time-second duration) + (/ (time-nanosecond duration) 1e9))) + +(define (seconds->string duration) + "Given DURATION in seconds, return a string representing it in 'mm:ss' or +'hh:mm:ss' format, as needed." + (if (not (number? duration)) + "00:00" + (let* ((total-seconds (nearest-exact-integer duration)) + (extra-seconds (modulo total-seconds 3600)) + (num-hours (quotient total-seconds 3600)) + (hours (and (positive? num-hours) num-hours)) + (mins (quotient extra-seconds 60)) + (secs (modulo extra-seconds 60))) + (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs)))) + +(define (byte-count->string size) + "Given SIZE in bytes, return a string representing it in a human-readable +way." + (let ((KiB 1024.) + (MiB (expt 1024. 2)) + (GiB (expt 1024. 3)) + (TiB (expt 1024. 4))) + (cond + ((< size KiB) (format #f "~dB" (nearest-exact-integer size))) + ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB)))) + ((< size GiB) (format #f "~,1fMiB" (/ size MiB))) + ((< size TiB) (format #f "~,2fGiB" (/ size GiB))) + (else (format #f "~,3fTiB" (/ size TiB)))))) + +(define (string-pad-middle left right len) + "Combine LEFT and RIGHT with enough padding in the middle so that the +resulting string has length at least LEN (it may overflow). If the string +does not overflow, the last char in RIGHT will be flush with the LEN +column." + (let* ((total-used (+ (string-length left) + (string-length right))) + (num-spaces (max 1 (- len total-used))) + (padding (make-string num-spaces #\space))) + (string-append left padding right))) + +(define (rate-limited proc interval) + "Return a procedure that will forward the invocation to PROC when the time +elapsed since the previous forwarded invocation is greater or equal to +INTERVAL (a time-duration object), otherwise does nothing and returns #f." + (let ((previous-at #f)) + (lambda args + (let* ((now (current-time time-monotonic)) + (forward-invocation (lambda () + (set! previous-at now) + (apply proc args)))) + (if previous-at + (let ((elapsed (time-difference now previous-at))) + (if (time>=? elapsed interval) + (forward-invocation) + #f)) + (forward-invocation)))))) + +(define current-terminal-columns + ;; Number of columns of the terminal. + (make-parameter 80)) + +(define* (progress-bar % #:optional (bar-width 20)) + "Return % as a string representing an ASCII-art progress bar. The total +width of the bar is BAR-WIDTH." + (let* ((fraction (/ % 100)) + (filled (inexact->exact (floor (* fraction bar-width)))) + (empty (- bar-width filled))) + (format #f "[~a~a]" + (make-string filled #\#) + (make-string empty #\space)))) + +(define* (progress-reporter/file file size + #:optional (log-port (current-output-port)) + #:key (abbreviation basename)) + "Return a object to show the progress of FILE's download, +which is SIZE bytes long. The progress report is written to LOG-PORT, with +ABBREVIATION used to shorten FILE for display." + (let ((start-time (current-time time-monotonic)) + (transferred 0)) + (define (render) + "Write the progress report to LOG-PORT." + (define elapsed + (duration->seconds + (time-difference (current-time time-monotonic) start-time))) + (if (number? size) + (let* ((% (* 100.0 (/ transferred size))) + (throughput (/ transferred elapsed)) + (left (format #f " ~a ~a" + (abbreviation file) + (byte-count->string size))) + (right (format #f "~a/s ~a ~a~6,1f%" + (byte-count->string throughput) + (seconds->string elapsed) + (progress-bar %) %))) + (display "\r\x1b[K" log-port) + (display (string-pad-middle left right + (current-terminal-columns)) + log-port) + (force-output log-port)) + (let* ((throughput (/ transferred elapsed)) + (left (format #f " ~a" + (abbreviation file))) + (right (format #f "~a/s ~a | ~a transferred" + (byte-count->string throughput) + (seconds->string elapsed) + (byte-count->string transferred)))) + (display "\r\x1b[K" log-port) + (display (string-pad-middle left right + (current-terminal-columns)) + log-port) + (force-output log-port)))) + + (progress-reporter + (start render) + ;; Report the progress every 300ms or longer. + (report + (let ((rate-limited-render + (rate-limited render (make-time time-monotonic 300000000 0)))) + (lambda (value) + (set! transferred value) + (rate-limited-render)))) + ;; Don't miss the last report. + (stop render)))) + +;; TODO: replace '(@ (guix build utils) dump-port))'. +(define* (dump-port* in out + #:key (buffer-size 16384) + (reporter progress-reporter/silent)) + "Read as much data as possible from IN and write it to OUT, using chunks of +BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or +less, report the total number of bytes transferred to the REPORTER, which +should be a object." + (define buffer + (make-bytevector buffer-size)) + + (call-with-progress-reporter reporter + (lambda (report) + (let loop ((total 0) + (bytes (get-bytevector-n! in buffer 0 buffer-size))) + (or (eof-object? bytes) + (let ((total (+ total bytes))) + (put-bytevector out buffer 0 bytes) + (report total) + (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 8225f82bb..1b99bc62c 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -25,7 +25,9 @@ #:use-module (guix base32) #:use-module ((guix download) #:hide (url-fetch)) #:use-module ((guix build download) - #:select (url-fetch current-terminal-columns)) + #:select (url-fetch)) + #:use-module ((guix progress) + #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (web uri) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 921a7c679..b9d86e3ff 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -33,13 +33,12 @@ #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) - #:select (current-terminal-columns - progress-reporter/file - uri-abbreviation nar-uri-abbreviation + #:select (uri-abbreviation nar-uri-abbreviation (open-connection-for-uri . guix:open-connection-for-uri) close-connection store-path-abbreviation byte-count->string)) + #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) #:use-module (ice-9 rdelim) diff --git a/guix/utils.scm b/guix/utils.scm index de4aa6531..e1615fcf4 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -33,7 +33,6 @@ #:autoload (rnrs io ports) (make-custom-binary-input-port) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) - #:use-module (guix records) #:use-module ((guix build utils) #:select (dump-port mkdir-p)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module (ice-9 format) @@ -95,13 +94,7 @@ call-with-decompressed-port compressed-output-port call-with-compressed-output-port - canonical-newline-port - - - progress-reporter - make-progress-reporter - progress-reporter? - call-with-progress-reporter)) + canonical-newline-port)) ;;; @@ -755,25 +748,6 @@ a location object." (column . ,(location-column loc)) (filename . ,(location-file loc)))) - -;;; -;;; Progress reporter. -;;; - -(define-record-type* - progress-reporter make-progress-reporter progress-reporter? - (start progress-reporter-start) ; thunk - (report progress-reporter-report) ; procedure - (stop progress-reporter-stop)) ; thunk - -(define (call-with-progress-reporter reporter proc) - "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} -with the resulting report procedure. When @var{proc} returns, the REPORTER is -stopped." - (match reporter - (($ start report stop) - (dynamic-wind start (lambda () (proc report)) stop)))) - ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: -- 2.14.2 From unknown Fri Aug 15 18:09:55 2025 X-Loop: help-debbugs@gnu.org Subject: bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: bug-guix@gnu.org Resent-Date: Wed, 18 Oct 2017 17:59:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 28709 X-GNU-PR-Package: guix X-GNU-PR-Keywords: To: Ludovic =?UTF-8?Q?Court=C3=A8s?= Cc: 28709@debbugs.gnu.org Received: via spool by 28709-submit@debbugs.gnu.org id=B28709.15083494966307 (code B ref 28709); Wed, 18 Oct 2017 17:59:01 +0000 Received: (at 28709) by debbugs.gnu.org; 18 Oct 2017 17:58:16 +0000 Received: from localhost ([127.0.0.1]:48572 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4sbf-0001df-M1 for submit@debbugs.gnu.org; Wed, 18 Oct 2017 13:58:15 -0400 Received: from li622-129.members.linode.com ([212.71.249.129]:58012 helo=mira.cbaines.net) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e4sbb-0001dT-OA for 28709@debbugs.gnu.org; Wed, 18 Oct 2017 13:58:12 -0400 Received: by mira.cbaines.net (Postfix, from userid 113) id F312E154C9E; Wed, 18 Oct 2017 18:58:10 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=ALL_TRUSTED,BAYES_00, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.0 Received: from localhost (cpc102582-walt20-2-0-cust14.13-2.cable.virginm.net [86.27.34.15]) by mira.cbaines.net (Postfix) with ESMTPSA id 024EA154C5B; Wed, 18 Oct 2017 18:58:09 +0100 (BST) Date: Wed, 18 Oct 2017 18:58:04 +0100 From: Christopher Baines Message-ID: <20171018185804.33c61a5b@cbaines.net> In-Reply-To: <20171017084807.15901-1-ludo@gnu.org> References: <8760bu60sv.fsf@gnu.org> <20171017084807.15901-1-ludo@gnu.org> X-Mailer: Claws Mail 3.15.1-dirty (GTK+ 2.24.31; x86_64-unknown-linux-gnu) MIME-Version: 1.0 Content-Type: multipart/signed; micalg=pgp-sha512; boundary="Sig_/t.FcocO=joFvj4UJO.4LR5l"; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -0.0 (/) --Sig_/t.FcocO=joFvj4UJO.4LR5l Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable On Tue, 17 Oct 2017 10:48:03 +0200 Ludovic Court=C3=A8s wrote: > Hello, >=20 > Here=E2=80=99s a ready-to-merge patch series. Once applied, nars > (aka. =E2=80=9Csubstitutes=E2=80=9D) are downloaded and extracted when a = VCS checkout > fails. This will address cases such as the recent Guile-Git repository > renaming for people who have disabled substitutes. >=20 > I=E2=80=99m Cc=E2=80=99ing =E5=AE=8B=E6=96=87=E6=AD=A6 because this also = moves the progress-report code to > a new (guix progress) module. >=20 > Feedback welcome! >=20 > Ludo=E2=80=99. >=20 > Ludovic Court=C3=A8s (4): > download: Remove old-Guile leftovers. > download: Make 'http-fetch' public. > Add (guix progress). > download: Download a nar when a VCS checkout fails. >=20 > Makefile.am | 2 + > guix/build/download-nar.scm | 125 ++++++++++++++++++++++++ > guix/build/download.scm | 216 +++++---------------------------------= --- > guix/cvs-download.scm | 38 ++++++-- > guix/git-download.scm | 37 +++++-- > guix/hg-download.scm | 36 +++++-- > guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++= ++++++ > guix/scripts/download.scm | 4 +- > guix/scripts/substitute.scm | 5 +- > guix/utils.scm | 28 +----- > 10 files changed, 470 insertions(+), 249 deletions(-) > create mode 100644 guix/build/download-nar.scm > create mode 100644 guix/progress.scm >=20 This all sounds good to me Ludo, and I didn't spot anything of note when looking through the patches. --Sig_/t.FcocO=joFvj4UJO.4LR5l Content-Type: application/pgp-signature Content-Description: OpenPGP digital signature -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAlnnlixfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XfKuw//VvvfDOu+/qQ8mqyNZRQ/626fftQGEfp9O2y5nGTlE+voK15We6jwyqs/ V+RHrS35e8kHd1JBeKkrzUJplAll+98VDjgnXmdFoQ1+2VNcWUaSXKAp2Hgu7YI+ +N3DKThvskEA2BEsHT84VkqlK//nZZZsncqRxKYUvUWsop8mrS+62Z0G1GUTwPOC nyKOI5ZFU7rB+I/MIPY0bmTvC7gFz0gt82SBBdAVvW5gimY6EyROXylEE28VkE1R reSiq8xtAvcJlnJSUbE6Z5WWV6/hyUfVUio91dqi2EQmjWhHDrd8zCt8cPqHAP/R MUcHWVjRcEEFgQ3V74HowqiS3QHp9U4jxypursCdPd4Z07jyAmPYuJSUpr6TY0we XKeSrQO8Hhm16iriEpLCcB645B2bDR96iKCRrN53l3KGAPnmQzkVk8bQxsXU0PHn 2OXftMeljjQ+jevzFs35xXBWq/Thpj+vz7GhEYLGsEyNihnB5u2+uPsO9YQGcQZp IiXVg6WPjwGyMX3XLoFE/zM5G5n2s7ihsLxIuDaQ76bsjw3HSei2ndyYGr//I56O 2vig0nF6flY/gcmcefKU6F+1Ja5U2Hg90LvXg1i/rcluHs4FGe7kwYg5YXVH0F3h sckpUIbJFbXyVOItHrPdhibImtFUCKiMSQiQamjY7PbB58384rg= =sGLV -----END PGP SIGNATURE----- --Sig_/t.FcocO=joFvj4UJO.4LR5l-- From unknown Fri Aug 15 18:09:55 2025 MIME-Version: 1.0 X-Mailer: MIME-tools 5.505 (Entity 5.505) X-Loop: help-debbugs@gnu.org From: help-debbugs@gnu.org (GNU bug Tracking System) To: ludo@gnu.org (Ludovic =?UTF-8?Q?Court=C3=A8s?=) Subject: bug#28709: closed (Re: bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts) Message-ID: References: <87376ej0d0.fsf@gnu.org> <8760bu60sv.fsf@gnu.org> X-Gnu-PR-Message: they-closed 28709 X-Gnu-PR-Package: guix Reply-To: 28709@debbugs.gnu.org Date: Thu, 19 Oct 2017 21:27:02 +0000 Content-Type: multipart/mixed; boundary="----------=_1508448422-2248-1" This is a multi-part message in MIME format... ------------=_1508448422-2248-1 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable Content-Type: text/plain; charset="utf-8" Your bug report #28709: Content-addressed mirrors for Git checkouts which was filed against the guix package, has been closed. The explanation is attached below, along with your original report. If you require more details, please reply to 28709@debbugs.gnu.org. --=20 28709: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3D28709 GNU Bug Tracking System Contact help-debbugs@gnu.org with problems ------------=_1508448422-2248-1 Content-Type: message/rfc822 Content-Disposition: inline Content-Transfer-Encoding: 7bit Received: (at 28709-done) by debbugs.gnu.org; 19 Oct 2017 21:26:07 +0000 Received: from localhost ([127.0.0.1]:50787 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e5IKN-0000Yw-JQ for submit@debbugs.gnu.org; Thu, 19 Oct 2017 17:26:07 -0400 Received: from hera.aquilenet.fr ([141.255.128.1]:39703) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1e5IKM-0000Yo-7P for 28709-done@debbugs.gnu.org; Thu, 19 Oct 2017 17:26:06 -0400 Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id F2D73F398; Thu, 19 Oct 2017 23:26:06 +0200 (CEST) X-Virus-Scanned: Debian amavisd-new at aquilenet.fr Received: from hera.aquilenet.fr ([127.0.0.1]) by localhost (hera.aquilenet.fr [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id j6KZ2B0yWDm3; Thu, 19 Oct 2017 23:26:06 +0200 (CEST) Received: from ribbon (unknown [IPv6:2a01:e0a:1d:7270:6a6c:dc17:fc02:cfda]) by hera.aquilenet.fr (Postfix) with ESMTPSA id 0D206E4A5; Thu, 19 Oct 2017 23:26:05 +0200 (CEST) From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) To: Christopher Baines Subject: Re: bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts References: <8760bu60sv.fsf@gnu.org> <20171017084807.15901-1-ludo@gnu.org> <20171018185804.33c61a5b@cbaines.net> Date: Thu, 19 Oct 2017 23:26:03 +0200 In-Reply-To: <20171018185804.33c61a5b@cbaines.net> (Christopher Baines's message of "Wed, 18 Oct 2017 18:58:04 +0100") Message-ID: <87376ej0d0.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.3 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-Spam-Score: 1.0 (+) X-Debbugs-Envelope-To: 28709-done Cc: 28709-done@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: 1.0 (+) Howdy! Christopher Baines skribis: > On Tue, 17 Oct 2017 10:48:03 +0200 > Ludovic Court=C3=A8s wrote: [...] >> Ludovic Court=C3=A8s (4): >> download: Remove old-Guile leftovers. >> download: Make 'http-fetch' public. >> Add (guix progress). >> download: Download a nar when a VCS checkout fails. >>=20 >> Makefile.am | 2 + >> guix/build/download-nar.scm | 125 ++++++++++++++++++++++++ >> guix/build/download.scm | 216 +++++--------------------------------= ---- >> guix/cvs-download.scm | 38 ++++++-- >> guix/git-download.scm | 37 +++++-- >> guix/hg-download.scm | 36 +++++-- >> guix/progress.scm | 228 +++++++++++++++++++++++++++++++++++++= +++++++ >> guix/scripts/download.scm | 4 +- >> guix/scripts/substitute.scm | 5 +- >> guix/utils.scm | 28 +----- >> 10 files changed, 470 insertions(+), 249 deletions(-) >> create mode 100644 guix/build/download-nar.scm >> create mode 100644 guix/progress.scm >>=20 > > This all sounds good to me Ludo, and I didn't spot anything of note > when looking through the patches. Thank you, pushed! Ludo=E2=80=99. ------------=_1508448422-2248-1 Content-Type: message/rfc822 Content-Disposition: inline Content-Transfer-Encoding: 7bit Received: (at submit) by debbugs.gnu.org; 4 Oct 2017 21:49:54 +0000 Received: from localhost ([127.0.0.1]:49429 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dzrYA-0007v3-5N for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:54 -0400 Received: from eggs.gnu.org ([208.118.235.92]:42698) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dzrY8-0007ur-Dg for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:52 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dzrY1-0002XE-Ma for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:47 -0400 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=-0.0 required=5.0 tests=BAYES_20,RP_MATCHES_RCVD, URIBL_BLOCKED autolearn=disabled version=3.3.2 Received: from lists.gnu.org ([2001:4830:134:3::11]:41576) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1dzrY1-0002XA-Io for submit@debbugs.gnu.org; Wed, 04 Oct 2017 17:49:45 -0400 Received: from eggs.gnu.org ([2001:4830:134:3::10]:33657) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dzrXz-0006Db-Oi for bug-guix@gnu.org; Wed, 04 Oct 2017 17:49:45 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dzrXy-0002V0-Ag for bug-guix@gnu.org; Wed, 04 Oct 2017 17:49:43 -0400 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:38293) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dzrXu-0002SF-Rl; Wed, 04 Oct 2017 17:49:38 -0400 Received: from [2a01:e0a:1d:7270:6a6c:dc17:fc02:cfda] (port=47948 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1dzrXu-0007sS-Dg; Wed, 04 Oct 2017 17:49:38 -0400 From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) To: bug-guix@gnu.org Subject: Content-addressed mirrors for Git checkouts X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 13 =?utf-8?Q?Vend=C3=A9miaire?= an 226 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Wed, 04 Oct 2017 23:49:36 +0200 Message-ID: <8760bu60sv.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.3 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Received-From: 2001:4830:134:3::11 X-Spam-Score: -5.0 (-----) X-Debbugs-Envelope-To: submit Cc: Leo Famulari X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -5.0 (-----) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello! Someone on #guix reported a failure to build Guile-Git from Guix 0.13.0 because the old repo at gitlab.com has disappeared. For tarballs, we have content addressed mirrors, in particular the /file URL of =E2=80=98guix publish=E2=80=99. However, that=E2=80=99s only for re= gular files, not for directories like Git checkouts. For directories (and store items in general), we have the /nar URLs though (normally used for substitutes). This patch uses /nar URLs as a fallback mirror (it=E2=80=99s content-addressed, even though the hash in th= e URL is not directly the content hash) for Git clones that fail. It=E2=80=99s rough on the edges (no TLS, no compression), but it shows that= it=E2=80=99s a viable solution. It would take some thought to avoid duplicating it between git, hg, etc. Thoughts? Ludo=E2=80=99. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable diff --git a/guix/build/git.scm b/guix/build/git.scm index c1af545a7..223e79227 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright =C2=A9 2014, 2016 Ludovic Court=C3=A8s +;;; Copyright =C2=A9 2014, 2016, 2017 Ludovic Court=C3=A8s ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,14 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (guix build git) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (guix serialization) #:use-module (guix build utils) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:use-module (ice-9 match) #:export (git-fetch)) =20 ;;; Commentary: @@ -27,6 +34,37 @@ ;;; ;;; Code: =20 +(define (urls-for-item item) + "Return the fallback nar URL for ITEM--e.g., \"cabbag3=E2=80=A6-foo-1.2-= checkout\"." + ;; TODO: Use the /gzip URLs, make it configurable, and use TLS. + (list (string-append "http://mirror.hydra.gnu.org/guix/nar/" item) + (string-append "http://berlin.guixsd.org/nar/" item))) + +(define (download-nar item directory) + "Download Git checkout ITEM to DIRECTORY as a nar." + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-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 (((response port) + (http-get url #:streaming? #t))) + (if (=3D 200 (response-code response)) + (let ((size (response-content-length response))) + (if size + (format #t "Downloading from ~a (~,2h MiB)...~%" + url (/ size (expt 2 20.))) + (format #t "Downloading from ~a...~%" url)) + (restore-file port directory) + (close-port port) + #t) + (loop rest)))) + (() + #f)))) + (define* (git-fetch url commit directory #:key (git-command "git") recursive?) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit @@ -39,26 +77,27 @@ recursively. Return #t on success, #f otherwise." =20 ;; We cannot use "git clone --recursive" since the following "git checko= ut" ;; effectively removes sub-module checkouts as of Git 2.6.3. - (and (zero? (system* git-command "clone" url directory)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - (when recursive? - ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" - "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (if (zero? (system* git-command "clone" url directory)) + (with-directory-excursion directory + (system* git-command "tag" "-l") + (and (zero? (system* git-command "checkout" commit)) + (begin + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" + "--init" "--recursive")) + (error "failed to fetch sub-modules" url)) =20 - ;; In sub-modules, '.git' is a flat file, not a director= y, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) =20 - ;; The contents of '.git' vary as a function of the current - ;; status of the Git repo. Since we want a fixed output, = this - ;; directory needs to be taken out. - (delete-file-recursively ".git") - #t))))) + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, t= his + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t))) + (download-nar (basename directory) directory))) =20 ;;; git.scm ends here diff --git a/guix/git-download.scm b/guix/git-download.scm index 7397cbe7f..ffae8fcc3 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) @@ -78,8 +79,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a ge= neric name if #f." '())) =20 (define build - (with-imported-modules '((guix build git) - (guix build utils)) + (with-imported-modules (source-module-closure + '((guix build git))) #~(begin (use-modules (guix build git) (guix build utils) --=-=-=-- ------------=_1508448422-2248-1--