From mboxrd@z Thu Jan 1 00:00:00 1970 From: ludo@gnu.org (Ludovic =?UTF-8?Q?Court=C3=A8s?=) Subject: bug#28709: Content-addressed mirrors for Git checkouts Date: Wed, 04 Oct 2017 23:49:36 +0200 Message-ID: <8760bu60sv.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:33716) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dzrYJ-0006H6-F1 for bug-guix@gnu.org; Wed, 04 Oct 2017 17:50:04 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dzrYI-0002sD-5J for bug-guix@gnu.org; Wed, 04 Oct 2017 17:50:03 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40748) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dzrYI-0002s5-1d for bug-guix@gnu.org; Wed, 04 Oct 2017 17:50:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dzrYH-0007vX-S6 for bug-guix@gnu.org; Wed, 04 Oct 2017 17:50:01 -0400 Sender: "Debbugs-submit" Resent-Message-ID: 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 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 --=-=-= 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) --=-=-=--