From mboxrd@z Thu Jan 1 00:00:00 1970 From: Andy Wingo Subject: [PATCH 1/7] guix: git: Support shallow git clones if a tag is available Date: Tue, 18 Aug 2015 10:03:06 +0200 Message-ID: <1439893929.575691.5108@rusty> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:47560) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZReBk-0007Pi-9v for guix-devel@gnu.org; Tue, 18 Aug 2015 06:32:17 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZReBf-0007IM-99 for guix-devel@gnu.org; Tue, 18 Aug 2015 06:32:16 -0400 Received: from pb-sasl0.int.icgroup.com ([208.72.237.25]:64863 helo=sasl.smtp.pobox.com) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZReBf-0007II-5n for guix-devel@gnu.org; Tue, 18 Aug 2015 06:32:11 -0400 Received: from sasl.smtp.pobox.com (unknown [127.0.0.1]) by pb-sasl0.pobox.com (Postfix) with ESMTP id E385211831 for ; Tue, 18 Aug 2015 06:32:09 -0400 (EDT) Received: from pb-sasl0. (unknown [127.0.0.1]) by pb-sasl0.pobox.com (Postfix) with ESMTP id DB02911830 for ; Tue, 18 Aug 2015 06:32:09 -0400 (EDT) Received: from rusty (unknown [88.160.190.192]) (using TLSv1 with cipher ECDHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by pb-sasl0.pobox.com (Postfix) with ESMTPSA id E687D1182F for ; Tue, 18 Aug 2015 06:32:08 -0400 (EDT) List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@gnu.org * guix/build/git.scm (git-fetch): Instead of cloning the remote repo, use the lower-level "init" / "fetch" / "checkout" operations. This lets us make a shallow checkout if we are checking out a tag. * guix/git-download.scm (): Add tag field. (git-fetch): Support git references with tags but no commits. --- guix/build/git.scm | 58 ++++++++++++++++++++++++++++++++++----------------- guix/git-download.scm | 10 +++++++-- 2 files changed, 47 insertions(+), 21 deletions(-) diff --git a/guix/build/git.scm b/guix/build/git.scm index 121f07a..1af547f 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -28,32 +28,52 @@ ;;; Code: (define* (git-fetch url commit directory - #:key (git-command "git") recursive?) + #:key tag (git-command "git") recursive?) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit identifier. When RECURSIVE? is true, all the sub-modules of URL are fetched, recursively. Return #t on success, #f otherwise." - ;; Disable TLS certificate verification. The hash of the checkout is known ;; in advance anyway. (setenv "GIT_SSL_NO_VERIFY" "true") - (let ((args `("clone" ,@(if recursive? '("--recursive") '()) - ,url ,directory))) - (and (zero? (apply system* git-command args)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - ;; 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") + (mkdir directory) + (with-directory-excursion directory + (and (zero? (system* git-command "init")) + (zero? (system* git-command "remote" "add" "origin" url)) + (cond + ;; If there's a tag, do a shallow fetch. Otherwise we do a full + ;; fetch. + (tag + (and (zero? (system* git-command "fetch" "--depth=1" "origin" tag)) + ;; Either there is no commit specified, in which case we are + ;; good, or there is a commit and it is the same as the tag, + ;; in which case we're still good, or there's a commit and + ;; it's under the tag so we have to unshallow the checkout and + ;; try again. + (if commit + (or (zero? (system* git-command "checkout" commit)) + (and (zero? (system* git-command "fetch" "--unshallow")) + (zero? (system* git-command "checkout" commit)))) + (zero? (system* git-command "checkout" "FETCH_HEAD"))))) + (else + ;; Fall back to a full fetch. In that case print available tags. + (and (zero? (system* git-command "fetch" "origin")) + (zero? (system* git-command "tag" "-l")) + (zero? (system* git-command "checkout" commit))))) + (or (not recursive?) + (zero? (system* git-command + "submodule" "update" "--init" "--recursive"))) + (begin + ;; 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") - (when recursive? - ;; 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$"))) - #t)))))) + (when recursive? + ;; 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$"))) + #t)))) ;;; git.scm ends here diff --git a/guix/git-download.scm b/guix/git-download.scm index 0f2218c..43bc466 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -28,6 +28,7 @@ git-reference? git-reference-url git-reference-commit + git-reference-tag git-reference-recursive? git-fetch)) @@ -44,7 +45,8 @@ git-reference make-git-reference git-reference? (url git-reference-url) - (commit git-reference-commit) + (commit git-reference-commit (default #f)) + (tag git-reference-tag (default #f)) (recursive? git-reference-recursive? ; whether to recurse into sub-modules (default #f))) @@ -81,8 +83,12 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." dirs))) (git-fetch '#$(git-reference-url ref) - '#$(git-reference-commit ref) + (or '#$(git-reference-commit ref) + '#$(git-reference-tag ref)) #$output + ;; FIXME: Pass #:tag when fixed daemons are widely + ;; deployed. + ;; #:tag '#$(git-reference-tag ref) #:recursive? '#$(git-reference-recursive? ref) #:git-command (string-append #+git "/bin/git")))) -- 2.4.3